packages feed

ghc-lib 8.8.4.20210620 → 8.10.1.20200324

raw patch · 362 files changed

+43351/−37866 lines, 362 filesdep −rtsdep ~basedep ~ghc-lib-parserdep ~ghc-prim

Dependencies removed: rts

Dependency ranges changed: base, ghc-lib-parser, ghc-prim

Files

+ compiler/GHC/HsToCore/PmCheck.hs view
@@ -0,0 +1,1375 @@+{-+Author: George Karachalias <george.karachalias@cs.kuleuven.be>++Pattern Matching Coverage Checking.+-}++{-# LANGUAGE CPP            #-}+{-# LANGUAGE GADTs          #-}+{-# LANGUAGE TupleSections  #-}+{-# LANGUAGE ViewPatterns   #-}+{-# LANGUAGE MultiWayIf     #-}+{-# LANGUAGE LambdaCase     #-}++module GHC.HsToCore.PmCheck (+        -- Checking and printing+        checkSingle, checkMatches, checkGuardMatches,+        needToRunPmCheck, isMatchContextPmChecked,++        -- See Note [Type and Term Equality Propagation]+        addTyCsDs, addScrutTmCs, addPatTmCs+    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.HsToCore.PmCheck.Types+import GHC.HsToCore.PmCheck.Oracle+import GHC.HsToCore.PmCheck.Ppr+import BasicTypes (Origin, isGenerated)+import CoreSyn (CoreExpr, Expr(Var,App))+import FastString (unpackFS, lengthFS)+import DynFlags+import GHC.Hs+import TcHsSyn+import Id+import ConLike+import Name+import FamInst+import TysWiredIn+import SrcLoc+import Util+import Outputable+import DataCon+import TyCon+import Var (EvVar)+import Coercion+import TcEvidence+import {-# SOURCE #-} DsExpr (dsExpr, dsLExpr, dsSyntaxExpr)+import {-# SOURCE #-} DsBinds (dsHsWrapper)+import DsUtils (selectMatchVar)+import MatchLit (dsLit, dsOverLit)+import DsMonad+import Bag+import TyCoRep+import Type+import DsUtils       (isTrueLHsExpr)+import Maybes+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad (when, forM_, zipWithM)+import Data.List (elemIndex)+import qualified Data.Semigroup as Semi++{-+This module checks pattern matches for:+\begin{enumerate}+  \item Equations that are redundant+  \item Equations with inaccessible right-hand-side+  \item Exhaustiveness+\end{enumerate}++The algorithm is based on the paper:++  "GADTs Meet Their Match:+     Pattern-matching Warnings That Account for GADTs, Guards, and Laziness"++    http://people.cs.kuleuven.be/~george.karachalias/papers/p424-karachalias.pdf++%************************************************************************+%*                                                                      *+                     Pattern Match Check Types+%*                                                                      *+%************************************************************************+-}++-- | A very simple language for pattern guards. Let bindings, bang patterns,+-- and matching variables against flat constructor patterns.+data PmGrd+  = -- | @PmCon x K tvs dicts args@ corresponds to a+    -- @K tvs dicts args <- x@ guard. The @tvs@ and @args@ are bound in this+    -- construct, the @x@ is just a use.+    -- For the arguments' meaning see 'GHC.Hs.Pat.ConPatOut'.+    PmCon {+      pm_id          :: !Id,+      pm_con_con     :: !PmAltCon,+      pm_con_tvs     :: ![TyVar],+      pm_con_dicts   :: ![EvVar],+      pm_con_args    :: ![Id]+    }++    -- | @PmBang x@ corresponds to a @seq x True@ guard.+  | PmBang {+      pm_id          :: !Id+    }++    -- | @PmLet x expr@ corresponds to a @let x = expr@ guard. This actually+    -- /binds/ @x@.+  | PmLet {+      pm_id       :: !Id,+      pm_let_expr :: !CoreExpr+    }++-- | Should not be user-facing.+instance Outputable PmGrd where+  ppr (PmCon x alt _con_tvs _con_dicts con_args)+    = hsep [ppr alt, hsep (map ppr con_args), text "<-", ppr x]+  ppr (PmBang x) = char '!' <> ppr x+  ppr (PmLet x expr) = hsep [text "let", ppr x, text "=", ppr expr]++type GrdVec = [PmGrd]++-- | Each 'Delta' is proof (i.e., a model of the fact) that some values are not+-- covered by a pattern match. E.g. @f Nothing = <rhs>@ might be given an+-- uncovered set @[x :-> Just y]@ or @[x /= Nothing]@, where @x@ is the variable+-- matching against @f@'s first argument.+type Uncovered = [Delta]++-- Instead of keeping the whole sets in memory, we keep a boolean for both the+-- covered and the divergent set (we store the uncovered set though, since we+-- want to print it). For both the covered and the divergent we have:+--+--   True <=> The set is non-empty+--+-- hence:+--  C = True             ==> Useful clause (no warning)+--  C = False, D = True  ==> Clause with inaccessible RHS+--  C = False, D = False ==> Redundant clause++data Covered = Covered | NotCovered+  deriving Show++instance Outputable Covered where+  ppr = text . show++-- Like the or monoid for booleans+-- Covered = True, Uncovered = False+instance Semi.Semigroup Covered where+  Covered <> _ = Covered+  _ <> Covered = Covered+  NotCovered <> NotCovered = NotCovered++instance Monoid Covered where+  mempty = NotCovered+  mappend = (Semi.<>)++data Diverged = Diverged | NotDiverged+  deriving Show++instance Outputable Diverged where+  ppr = text . show++instance Semi.Semigroup Diverged where+  Diverged <> _ = Diverged+  _ <> Diverged = Diverged+  NotDiverged <> NotDiverged = NotDiverged++instance Monoid Diverged where+  mempty = NotDiverged+  mappend = (Semi.<>)++data Precision = Approximate | Precise+  deriving (Eq, Show)++instance Outputable Precision where+  ppr = text . show++instance Semi.Semigroup Precision where+  Approximate <> _ = Approximate+  _ <> Approximate = Approximate+  Precise <> Precise = Precise++instance Monoid Precision where+  mempty = Precise+  mappend = (Semi.<>)++-- | A triple <C,U,D> of covered, uncovered, and divergent sets.+--+-- Also stores a flag 'presultApprox' denoting whether we ran into the+-- 'maxPmCheckModels' limit for the purpose of hints in warning messages to+-- maybe increase the limit.+data PartialResult = PartialResult {+                        presultCovered   :: Covered+                      , presultUncovered :: Uncovered+                      , presultDivergent :: Diverged+                      , presultApprox    :: Precision }++emptyPartialResult :: PartialResult+emptyPartialResult = PartialResult { presultUncovered = mempty+                                   , presultCovered   = mempty+                                   , presultDivergent = mempty+                                   , presultApprox    = mempty }++combinePartialResults :: PartialResult -> PartialResult -> PartialResult+combinePartialResults (PartialResult cs1 vsa1 ds1 ap1) (PartialResult cs2 vsa2 ds2 ap2)+  = PartialResult (cs1 Semi.<> cs2)+                  (vsa1 Semi.<> vsa2)+                  (ds1 Semi.<> ds2)+                  (ap1 Semi.<> ap2) -- the result is approximate if either is++instance Outputable PartialResult where+  ppr (PartialResult c unc d pc)+    = hang (text "PartialResult" <+> ppr c <+> ppr d <+> ppr pc) 2 (ppr_unc unc)+    where+      ppr_unc = braces . fsep . punctuate comma . map ppr++instance Semi.Semigroup PartialResult where+  (<>) = combinePartialResults++instance Monoid PartialResult where+  mempty = emptyPartialResult+  mappend = (Semi.<>)++-- | Pattern check result+--+-- * Redundant clauses+-- * Not-covered clauses (or their type, if no pattern is available)+-- * Clauses with inaccessible RHS+-- * A flag saying whether we ran into the 'maxPmCheckModels' limit for the+--   purpose of suggesting to crank it up in the warning message+--+-- More details about the classification of clauses into useful, redundant+-- and with inaccessible right hand side can be found here:+--+--     https://gitlab.haskell.org/ghc/ghc/wikis/pattern-match-check+--+data PmResult =+  PmResult {+      pmresultRedundant    :: [Located [LPat GhcTc]]+    , pmresultUncovered    :: [Delta]+    , pmresultInaccessible :: [Located [LPat GhcTc]]+    , pmresultApproximate  :: Precision }++instance Outputable PmResult where+  ppr pmr = hang (text "PmResult") 2 $ vcat+    [ text "pmresultRedundant" <+> ppr (pmresultRedundant pmr)+    , text "pmresultUncovered" <+> ppr (pmresultUncovered pmr)+    , text "pmresultInaccessible" <+> ppr (pmresultInaccessible pmr)+    , text "pmresultApproximate" <+> ppr (pmresultApproximate pmr)+    ]++{-+%************************************************************************+%*                                                                      *+       Entry points to the checker: checkSingle and checkMatches+%*                                                                      *+%************************************************************************+-}++-- | Check a single pattern binding (let)+checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat GhcTc -> DsM ()+checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do+  tracePm "checkSingle" (vcat [ppr ctxt, ppr var, ppr p])+  res <- checkSingle' locn var p+  dsPmWarn dflags ctxt [var] res++-- | Check a single pattern binding (let)+checkSingle' :: SrcSpan -> Id -> Pat GhcTc -> DsM PmResult+checkSingle' locn var p = do+  fam_insts <- dsGetFamInstEnvs+  grds      <- translatePat fam_insts var p+  missing   <- getPmDelta+  tracePm "checkSingle': missing" (ppr missing)+  PartialResult cs us ds pc <- pmCheck grds [] 1 missing+  dflags <- getDynFlags+  us' <- getNFirstUncovered [var] (maxUncoveredPatterns dflags + 1) us+  let plain = PmResult { pmresultRedundant    = []+                       , pmresultUncovered    = us'+                       , pmresultInaccessible = []+                       , pmresultApproximate  = pc }+  return $ case (cs,ds) of+    (Covered   , _          ) -> plain                              -- useful+    (NotCovered, NotDiverged) -> plain { pmresultRedundant = m    } -- redundant+    (NotCovered, Diverged   ) -> plain { pmresultInaccessible = m } -- inaccessible rhs+  where m = [cL locn [cL locn p]]++-- | Exhaustive for guard matches, is used for guards in pattern bindings and+-- in @MultiIf@ expressions.+checkGuardMatches :: HsMatchContext Name          -- Match context+                  -> GRHSs GhcTc (LHsExpr GhcTc)  -- Guarded RHSs+                  -> DsM ()+checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do+    dflags <- getDynFlags+    let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss)+        dsMatchContext = DsMatchContext hs_ctx combinedLoc+        match = cL combinedLoc $+                  Match { m_ext = noExtField+                        , m_ctxt = hs_ctx+                        , m_pats = []+                        , m_grhss = guards }+    checkMatches dflags dsMatchContext [] [match]+checkGuardMatches _ (XGRHSs nec) = noExtCon nec++-- | Check a matchgroup (case, functions, etc.)+checkMatches :: DynFlags -> DsMatchContext+             -> [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM ()+checkMatches dflags ctxt vars matches = do+  tracePm "checkMatches" (hang (vcat [ppr ctxt+                               , ppr vars+                               , text "Matches:"])+                               2+                               (vcat (map ppr matches)))+  res <- checkMatches' vars matches+  dsPmWarn dflags ctxt vars res++-- | Check a matchgroup (case, functions, etc.).+checkMatches' :: [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM PmResult+checkMatches' vars matches = do+  init_delta <- getPmDelta+  missing <- case matches of+    -- This must be an -XEmptyCase. See Note [Checking EmptyCase]+    [] | [var] <- vars -> maybeToList <$> addTmCt init_delta (TmVarNonVoid var)+    _                  -> pure [init_delta]+  tracePm "checkMatches': missing" (ppr missing)+  (rs,us,ds,pc) <- go matches missing+  dflags <- getDynFlags+  us' <- getNFirstUncovered vars (maxUncoveredPatterns dflags + 1) us+  return $ PmResult {+                pmresultRedundant    = map hsLMatchToLPats rs+              , pmresultUncovered    = us'+              , pmresultInaccessible = map hsLMatchToLPats ds+              , pmresultApproximate  = pc }+  where+    go :: [LMatch GhcTc (LHsExpr GhcTc)] -> Uncovered+       -> DsM ( [LMatch GhcTc (LHsExpr GhcTc)]+              , Uncovered+              , [LMatch GhcTc (LHsExpr GhcTc)]+              , Precision)+    go []     missing = return ([], missing, [], Precise)+    go (m:ms) missing = do+      tracePm "checkMatches': go" (ppr m)+      dflags             <- getDynFlags+      fam_insts          <- dsGetFamInstEnvs+      (clause, guards)   <- translateMatch fam_insts vars m+      let limit                     = maxPmCheckModels dflags+          n_siblings                = length missing+          throttled_check delta     =+            snd <$> throttle limit (pmCheck clause guards) n_siblings delta++      r@(PartialResult cs missing' ds pc1) <- runMany throttled_check missing++      tracePm "checkMatches': go: res" (ppr r)+      (rs, final_u, is, pc2)  <- go ms missing'+      return $ case (cs, ds) of+        -- useful+        (Covered,  _    )        -> (rs, final_u,    is, pc1 Semi.<> pc2)+        -- redundant+        (NotCovered, NotDiverged) -> (m:rs, final_u, is, pc1 Semi.<> pc2)+        -- inaccessible+        (NotCovered, Diverged )   -> (rs, final_u, m:is, pc1 Semi.<> pc2)++    hsLMatchToLPats :: LMatch id body -> Located [LPat id]+    hsLMatchToLPats (dL->L l (Match { m_pats = pats })) = cL l pats+    hsLMatchToLPats _                                   = panic "checkMatches'"++getNFirstUncovered :: [Id] -> Int -> [Delta] -> DsM [Delta]+getNFirstUncovered _    0 _              = pure []+getNFirstUncovered _    _ []             = pure []+getNFirstUncovered vars n (delta:deltas) = do+  front <- provideEvidence vars n delta+  back <- getNFirstUncovered vars (n - length front) deltas+  pure (front ++ back)++{- Note [Checking EmptyCase]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-XEmptyCase is useful for matching on empty data types like 'Void'. For example,+the following is a complete match:++    f :: Void -> ()+    f x = case x of {}++Really, -XEmptyCase is the only way to write a program that at the same time is+safe (@f _ = error "boom"@ is not because of ⊥), doesn't trigger a warning+(@f !_ = error "inaccessible" has inaccessible RHS) and doesn't turn an+exception into divergence (@f x = f x@).++Semantically, unlike every other case expression, -XEmptyCase is strict in its+match var x, which rules out ⊥ as an inhabitant. So we add x /~ ⊥ to the+initial Delta and check if there are any values left to match on.+-}++{-+%************************************************************************+%*                                                                      *+              Transform source syntax to *our* syntax+%*                                                                      *+%************************************************************************+-}++-- -----------------------------------------------------------------------+-- * Utilities++-- | Smart constructor that eliminates trivial lets+mkPmLetVar :: Id -> Id -> GrdVec+mkPmLetVar x y | x == y = []+mkPmLetVar x y          = [PmLet x (Var y)]++-- | ADT constructor pattern => no existentials, no local constraints+vanillaConGrd :: Id -> DataCon -> [Id] -> PmGrd+vanillaConGrd scrut con arg_ids =+  PmCon { pm_id = scrut, pm_con_con = PmAltConLike (RealDataCon con)+        , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = arg_ids }++-- | Creates a 'GrdVec' refining a match var of list type to a list,+-- where list fields are matched against the incoming tagged 'GrdVec's.+-- For example:+--   @mkListGrds "a" "[(x, True <- x),(y, !y)]"@+-- to+--   @"[(x:b) <- a, True <- x, (y:c) <- b, seq y True, [] <- c]"@+-- where b,c are freshly allocated in @mkListGrds@ and a is the match variable.+mkListGrds :: Id -> [(Id, GrdVec)] -> DsM GrdVec+-- See Note [Order of guards matter] for why we need to intertwine guards+-- on list elements.+mkListGrds a []                  = pure [vanillaConGrd a nilDataCon []]+mkListGrds a ((x, head_grds):xs) = do+  b <- mkPmId (idType a)+  tail_grds <- mkListGrds b xs+  pure $ vanillaConGrd a consDataCon [x, b] : head_grds ++ tail_grds++-- | Create a 'GrdVec' refining a match variable to a 'PmLit'.+mkPmLitGrds :: Id -> PmLit -> DsM GrdVec+mkPmLitGrds x (PmLit _ (PmLitString s)) = do+  -- We translate String literals to list literals for better overlap reasoning.+  -- It's a little unfortunate we do this here rather than in+  -- 'GHC.HsToCore.PmCheck.Oracle.trySolve' and 'GHC.HsToCore.PmCheck.Oracle.addRefutableAltCon', but it's so much+  -- simpler here.+  -- See Note [Representation of Strings in TmState] in GHC.HsToCore.PmCheck.Oracle+  vars <- traverse mkPmId (take (lengthFS s) (repeat charTy))+  let mk_char_lit y c = mkPmLitGrds y (PmLit charTy (PmLitChar c))+  char_grdss <- zipWithM mk_char_lit vars (unpackFS s)+  mkListGrds x (zip vars char_grdss)+mkPmLitGrds x lit = do+  let grd = PmCon { pm_id = x+                  , pm_con_con = PmAltLit lit+                  , pm_con_tvs = []+                  , pm_con_dicts = []+                  , pm_con_args = [] }+  pure [grd]++-- -----------------------------------------------------------------------+-- * Transform (Pat Id) into GrdVec++-- | @translatePat _ x pat@ transforms @pat@ into a 'GrdVec', where+-- the variable representing the match is @x@.+translatePat :: FamInstEnvs -> Id -> Pat GhcTc -> DsM GrdVec+translatePat fam_insts x pat = case pat of+  WildPat  _ty -> pure []+  VarPat _ y   -> pure (mkPmLetVar (unLoc y) x)+  ParPat _ p   -> translateLPat fam_insts x p+  LazyPat _ _  -> pure [] -- like a wildcard+  BangPat _ p  ->+    -- Add the bang in front of the list, because it will happen before any+    -- nested stuff.+    (PmBang x :) <$> translateLPat fam_insts x p++  -- (x@pat)   ==>   Translate pat with x as match var and handle impedance+  --                 mismatch with incoming match var+  AsPat _ (dL->L _ y) p -> (mkPmLetVar y x ++) <$> translateLPat fam_insts y p++  SigPat _ p _ty -> translateLPat fam_insts x p++  -- See Note [Translate CoPats]+  -- Generally the translation is+  -- pat |> co   ===>   let y = x |> co, pat <- y  where y is a match var of pat+  CoPat _ wrapper p _ty+    | isIdHsWrapper wrapper                   -> translatePat fam_insts x p+    | WpCast co <-  wrapper, isReflexiveCo co -> translatePat fam_insts x p+    | otherwise -> do+        (y, grds) <- translatePatV fam_insts p+        wrap_rhs_y <- dsHsWrapper wrapper+        pure (PmLet y (wrap_rhs_y (Var x)) : grds)++  -- (n + k)  ===>   let b = x >= k, True <- b, let n = x-k+  NPlusKPat _pat_ty (dL->L _ n) k1 k2 ge minus -> do+    b <- mkPmId boolTy+    let grd_b = vanillaConGrd b trueDataCon []+    [ke1, ke2] <- traverse dsOverLit [unLoc k1, k2]+    rhs_b <- dsSyntaxExpr ge    [Var x, ke1]+    rhs_n <- dsSyntaxExpr minus [Var x, ke2]+    pure [PmLet b rhs_b, grd_b, PmLet n rhs_n]++  -- (fun -> pat)   ===>   let y = fun x, pat <- y where y is a match var of pat+  ViewPat _arg_ty lexpr pat -> do+    (y, grds) <- translateLPatV fam_insts pat+    fun <- dsLExpr lexpr+    pure $ PmLet y (App fun (Var x)) : grds++  -- list+  ListPat (ListPatTc _elem_ty Nothing) ps ->+    translateListPat fam_insts x ps++  -- overloaded list+  ListPat (ListPatTc elem_ty (Just (pat_ty, to_list))) pats -> do+    dflags <- getDynFlags+    case splitListTyConApp_maybe pat_ty of+      Just _e_ty+        | not (xopt LangExt.RebindableSyntax dflags)+        -- Just translate it as a regular ListPat+        -> translateListPat fam_insts x pats+      _ -> do+        y <- mkPmId (mkListTy elem_ty)+        grds <- translateListPat fam_insts y pats+        rhs_y <- dsSyntaxExpr to_list [Var x]+        pure $ PmLet y rhs_y : grds++    -- (a) In the presence of RebindableSyntax, we don't know anything about+    --     `toList`, we should treat `ListPat` as any other view pattern.+    --+    -- (b) In the absence of RebindableSyntax,+    --     - If the pat_ty is `[a]`, then we treat the overloaded list pattern+    --       as ordinary list pattern. Although we can give an instance+    --       `IsList [Int]` (more specific than the default `IsList [a]`), in+    --       practice, we almost never do that. We assume the `to_list` is+    --       the `toList` from `instance IsList [a]`.+    --+    --     - Otherwise, we treat the `ListPat` as ordinary view pattern.+    --+    -- See #14547, especially comment#9 and comment#10.++  ConPatOut { pat_con     = (dL->L _ con)+            , pat_arg_tys = arg_tys+            , pat_tvs     = ex_tvs+            , pat_dicts   = dicts+            , pat_args    = ps } -> do+    translateConPatOut fam_insts x con arg_tys ex_tvs dicts ps++  NPat ty (dL->L _ olit) mb_neg _ -> do+    -- See Note [Literal short cut] in MatchLit.hs+    -- We inline the Literal short cut for @ty@ here, because @ty@ is more+    -- precise than the field of OverLitTc, which is all that dsOverLit (which+    -- normally does the literal short cut) can look at. Also @ty@ matches the+    -- type of the scrutinee, so info on both pattern and scrutinee (for which+    -- short cutting in dsOverLit works properly) is overloaded iff either is.+    dflags <- getDynFlags+    core_expr <- case olit of+      OverLit{ ol_val = val, ol_ext = OverLitTc rebindable _ }+        | not rebindable+        , Just expr <- shortCutLit dflags val ty+        -> dsExpr expr+      _ -> dsOverLit olit+    let lit  = expectJust "failed to detect OverLit" (coreExprAsPmLit core_expr)+    let lit' = case mb_neg of+          Just _  -> expectJust "failed to negate lit" (negatePmLit lit)+          Nothing -> lit+    mkPmLitGrds x lit'++  LitPat _ lit -> do+    core_expr <- dsLit (convertLit lit)+    let lit = expectJust "failed to detect Lit" (coreExprAsPmLit core_expr)+    mkPmLitGrds x lit++  TuplePat _tys pats boxity -> do+    (vars, grdss) <- mapAndUnzipM (translateLPatV fam_insts) pats+    let tuple_con = tupleDataCon boxity (length vars)+    pure $ vanillaConGrd x tuple_con vars : concat grdss++  SumPat _ty p alt arity -> do+    (y, grds) <- translateLPatV fam_insts p+    let sum_con = sumDataCon alt arity+    -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+    pure $ vanillaConGrd x sum_con [y] : grds++  -- --------------------------------------------------------------------------+  -- Not supposed to happen+  ConPatIn  {} -> panic "Check.translatePat: ConPatIn"+  SplicePat {} -> panic "Check.translatePat: SplicePat"+  XPat      n  -> noExtCon n++-- | 'translatePat', but also select and return a new match var.+translatePatV :: FamInstEnvs -> Pat GhcTc -> DsM (Id, GrdVec)+translatePatV fam_insts pat = do+  x <- selectMatchVar pat+  grds <- translatePat fam_insts x pat+  pure (x, grds)++translateLPat :: FamInstEnvs -> Id -> LPat GhcTc -> DsM GrdVec+translateLPat fam_insts x = translatePat fam_insts x . unLoc++-- | 'translateLPat', but also select and return a new match var.+translateLPatV :: FamInstEnvs -> LPat GhcTc -> DsM (Id, GrdVec)+translateLPatV fam_insts = translatePatV fam_insts . unLoc++-- | @translateListPat _ x [p1, ..., pn]@ is basically+--   @translateConPatOut _ x $(mkListConPatOuts [p1, ..., pn]>@ without ever+-- constructing the 'ConPatOut's.+translateListPat :: FamInstEnvs -> Id -> [LPat GhcTc] -> DsM GrdVec+translateListPat fam_insts x pats = do+  vars_and_grdss <- traverse (translateLPatV fam_insts) pats+  mkListGrds x vars_and_grdss++-- | Translate a constructor pattern+translateConPatOut :: FamInstEnvs -> Id -> ConLike -> [Type] -> [TyVar]+                   -> [EvVar] -> HsConPatDetails GhcTc -> DsM GrdVec+translateConPatOut fam_insts x con univ_tys ex_tvs dicts = \case+    PrefixCon ps                 -> go_field_pats (zip [0..] ps)+    InfixCon  p1 p2              -> go_field_pats (zip [0..] [p1,p2])+    RecCon    (HsRecFields fs _) -> go_field_pats (rec_field_ps fs)+  where+    -- The actual argument types (instantiated)+    arg_tys     = conLikeInstOrigArgTys con (univ_tys ++ mkTyVarTys ex_tvs)++    -- Extract record field patterns tagged by field index from a list of+    -- LHsRecField+    rec_field_ps fs = map (tagged_pat . unLoc) fs+      where+        tagged_pat f = (lbl_to_index (getName (hsRecFieldId f)), hsRecFieldArg f)+        -- Unfortunately the label info is empty when the DataCon wasn't defined+        -- with record field labels, hence we translate to field index.+        orig_lbls        = map flSelector $ conLikeFieldLabels con+        lbl_to_index lbl = expectJust "lbl_to_index" $ elemIndex lbl orig_lbls++    go_field_pats tagged_pats = do+      -- The fields that appear might not be in the correct order. So first+      -- do a PmCon match, then force according to field strictness and then+      -- force evaluation of the field patterns in the order given by+      -- the first field of @tagged_pats@.+      -- See Note [Field match order for RecCon]++      -- Translate the mentioned field patterns. We're doing this first to get+      -- the Ids for pm_con_args.+      let trans_pat (n, pat) = do+            (var, pvec) <- translateLPatV fam_insts pat+            pure ((n, var), pvec)+      (tagged_vars, arg_grdss) <- mapAndUnzipM trans_pat tagged_pats++      let get_pat_id n ty = case lookup n tagged_vars of+            Just var -> pure var+            Nothing  -> mkPmId ty++      -- 1. the constructor pattern match itself+      arg_ids <- zipWithM get_pat_id [0..] arg_tys+      let con_grd = PmCon x (PmAltConLike con) ex_tvs dicts arg_ids++      -- 2. bang strict fields+      let arg_is_banged = map isBanged $ conLikeImplBangs con+          bang_grds     = map PmBang   $ filterByList arg_is_banged arg_ids++      -- 3. guards from field selector patterns+      let arg_grds = concat arg_grdss++      -- tracePm "ConPatOut" (ppr x $$ ppr con $$ ppr arg_ids)+      --+      -- Store the guards in exactly that order+      --      1.         2.           3.+      pure (con_grd : bang_grds ++ arg_grds)++-- Translate a single match+translateMatch :: FamInstEnvs -> [Id] -> LMatch GhcTc (LHsExpr GhcTc)+               -> DsM (GrdVec, [GrdVec])+translateMatch fam_insts vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss }))+  = do+      pats'   <- concat <$> zipWithM (translateLPat fam_insts) vars pats+      guards' <- mapM (translateGuards fam_insts) guards+      -- tracePm "translateMatch" (vcat [ppr pats, ppr pats', ppr guards, ppr guards'])+      return (pats', guards')+      where+        extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc]+        extractGuards (dL->L _ (GRHS _ gs _)) = map unLoc gs+        extractGuards _                       = panic "translateMatch"++        guards = map extractGuards (grhssGRHSs grhss)+translateMatch _ _ _ = panic "translateMatch"++-- -----------------------------------------------------------------------+-- * Transform source guards (GuardStmt Id) to simpler PmGrds++-- | Translate a list of guard statements to a 'GrdVec'+translateGuards :: FamInstEnvs -> [GuardStmt GhcTc] -> DsM GrdVec+translateGuards fam_insts guards =+  concat <$> mapM (translateGuard fam_insts) guards++-- | Translate a guard statement to a 'GrdVec'+translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM GrdVec+translateGuard fam_insts guard = case guard of+  BodyStmt _   e _ _ -> translateBoolGuard e+  LetStmt  _   binds -> translateLet (unLoc binds)+  BindStmt _ p e _ _ -> translateBind fam_insts p e+  LastStmt        {} -> panic "translateGuard LastStmt"+  ParStmt         {} -> panic "translateGuard ParStmt"+  TransStmt       {} -> panic "translateGuard TransStmt"+  RecStmt         {} -> panic "translateGuard RecStmt"+  ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt"+  XStmtLR nec        -> noExtCon nec++-- | Translate let-bindings+translateLet :: HsLocalBinds GhcTc -> DsM GrdVec+translateLet _binds = return []++-- | Translate a pattern guard+--   @pat <- e ==>  let x = e;  <guards for pat <- x>@+translateBind :: FamInstEnvs -> LPat GhcTc -> LHsExpr GhcTc -> DsM GrdVec+translateBind fam_insts p e = dsLExpr e >>= \case+  Var y+    | Nothing <- isDataConId_maybe y+    -- RHS is a variable, so that will allow us to omit the let+    -> translateLPat fam_insts y p+  rhs -> do+    (x, grds) <- translateLPatV fam_insts p+    pure (PmLet x rhs : grds)++-- | Translate a boolean guard+--   @e ==>  let x = e; True <- x@+translateBoolGuard :: LHsExpr GhcTc -> DsM GrdVec+translateBoolGuard e+  | isJust (isTrueLHsExpr e) = return []+    -- The formal thing to do would be to generate (True <- True)+    -- but it is trivial to solve so instead we give back an empty+    -- GrdVec for efficiency+  | otherwise = dsLExpr e >>= \case+      Var y+        | Nothing <- isDataConId_maybe y+        -- Omit the let by matching on y+        -> pure [vanillaConGrd y trueDataCon []]+      rhs -> do+        x <- mkPmId boolTy+        pure $ [PmLet x rhs, vanillaConGrd x trueDataCon []]++{- Note [Field match order for RecCon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The order for RecCon field patterns actually determines evaluation order of+the pattern match. For example:++  data T = T { a :: !Bool, b :: Char, c :: Int }+  f :: T -> ()+  f T{ c = 42, b = 'b' } = ()++Then+  * @f (T (error "a") (error "b") (error "c"))@ errors out with "a" because of+    the strict field.+  * @f (T True        (error "b") (error "c"))@ errors out with "c" because it+    is mentioned frist in the pattern match.++This means we can't just desugar the pattern match to the PatVec+@[T !_ 'b' 42]@. Instead we have to generate variable matches that have+strictness according to the field declarations and afterwards force them in the+right order. As a result, we get the PatVec @[T !_ b c, 42 <- c, 'b' <- b]@.++Of course, when the labels occur in the order they are defined, we can just use+the simpler desugaring.++Note [Order of guards matters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Similar to Note [Field match order for RecCon], the order in which the guards+for a pattern match appear matter. Consider a situation similar to T5117:++  f (0:_)  = ()+  f (0:[]) = ()++The latter clause is clearly redundant. Yet if we translate the second clause as++  [x:xs' <- xs, [] <- xs', 0 <- x]++We will say that the second clause only has an inaccessible RHS. That's because+we force the tail of the list before comparing its head! So the correct+translation would have been++  [x:xs' <- xs, 0 <- x, [] <- xs']++And we have to take in the guards on list cells into @mkListGrds@.++Note [Countering exponential blowup]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Precise pattern match exhaustiveness checking is necessarily exponential in+the size of some input programs. We implement a counter-measure in the form of+the -fmax-pmcheck-models flag, limiting the number of Deltas we check against+each pattern by a constant.++How do we do that? Consider++  f True True = ()+  f True True = ()++And imagine we set our limit to 1 for the sake of the example. The first clause+will be checked against the initial Delta, {}. Doing so will produce an+Uncovered set of size 2, containing the models {x/~True} and {x~True,y/~True}.+Also we find the first clause to cover the model {x~True,y~True}.++But the Uncovered set we get out of the match is too huge! We somehow have to+ensure not to make things worse as they are already, so we continue checking+with a singleton Uncovered set of the initial Delta {}. Why is this+sound (wrt. notion of the GADTs Meet their Match paper)? Well, it basically+amounts to forgetting that we matched against the first clause. The values+represented by {} are a superset of those represented by its two refinements+{x/~True} and {x~True,y/~True}.++This forgetfulness becomes very apparent in the example above: By continuing+with {} we don't detect the second clause as redundant, as it again covers the+same non-empty subset of {}. So we don't flag everything as redundant anymore,+but still will never flag something as redundant that isn't.++For exhaustivity, the converse applies: We will report @f@ as non-exhaustive+and report @f _ _@ as missing, which is a superset of the actual missing+matches. But soundness means we will never fail to report a missing match.++This mechanism is implemented in the higher-order function 'throttle'.++Note [Combinatorial explosion in guards]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Function with many clauses and deeply nested guards like in #11195 tend to+overwhelm the checker because they lead to exponential splitting behavior.+See the comments on #11195 on refinement trees. Every guard refines the+disjunction of Deltas by another split. This no different than the ConVar case,+but in stark contrast we mostly don't get any useful information out of that+split! Hence splitting k-fold just means having k-fold more work. The problem+exacerbates for larger k, because it gets even more unlikely that we can handle+all of the arising Deltas better than just continue working on the original+Delta.++We simply apply the same mechanism as in Note [Countering exponential blowup].+But we don't want to forget about actually useful info from pattern match+clauses just because we had one clause with many guards. So we set the limit for+guards much lower.++Note [Translate CoPats]+~~~~~~~~~~~~~~~~~~~~~~~+The pattern match checker did not know how to handle coerced patterns `CoPat`+efficiently, which gave rise to #11276. The original approach translated+`CoPat`s:++    pat |> co    ===>    x (pat <- (x |> co))++Why did we do this seemingly unnecessary expansion in the first place?+The reason is that the type of @pat |> co@ (which is the type of the value+abstraction we match against) might be different than that of @pat@. Data+instances such as @Sing (a :: Bool)@ are a good example of this: If we would+just drop the coercion, we'd get a type error when matching @pat@ against its+value abstraction, with the result being that pmIsSatisfiable decides that every+possible data constructor fitting @pat@ is rejected as uninhabitated, leading to+a lot of false warnings.++But we can check whether the coercion is a hole or if it is just refl, in+which case we can drop it.++%************************************************************************+%*                                                                      *+                 Utilities for Pattern Match Checking+%*                                                                      *+%************************************************************************+-}++-- ----------------------------------------------------------------------------+-- * Basic utilities++{-+Note [Extensions to GADTs Meet Their Match]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The GADTs Meet Their Match paper presents the formalism that GHC's coverage+checker adheres to. Since the paper's publication, there have been some+additional features added to the coverage checker which are not described in+the paper. This Note serves as a reference for these new features.++* Value abstractions are severely simplified to the point where they are just+  variables. The information about the shape of a variable is encoded in+  the oracle state 'Delta' instead.+* Handling of uninhabited fields like `!Void`.+  See Note [Strict argument type constraints] in GHC.HsToCore.PmCheck.Oracle.+* Efficient handling of literal splitting, large enumerations and accurate+  redundancy warnings for `COMPLETE` groups through the oracle.++Note [Filtering out non-matching COMPLETE sets]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Currently, conlikes in a COMPLETE set are simply grouped by the+type constructor heading the return type. This is nice and simple, but it does+mean that there are scenarios when a COMPLETE set might be incompatible with+the type of a scrutinee. For instance, consider (from #14135):++  data Foo a = Foo1 a | Foo2 a++  pattern MyFoo2 :: Int -> Foo Int+  pattern MyFoo2 i = Foo2 i++  {-# COMPLETE Foo1, MyFoo2 #-}++  f :: Foo a -> a+  f (Foo1 x) = x++`f` has an incomplete pattern-match, so when choosing which constructors to+report as unmatched in a warning, GHC must choose between the original set of+data constructors {Foo1, Foo2} and the COMPLETE set {Foo1, MyFoo2}. But observe+that GHC shouldn't even consider the COMPLETE set as a possibility: the return+type of MyFoo2, Foo Int, does not match the type of the scrutinee, Foo a, since+there's no substitution `s` such that s(Foo Int) = Foo a.++To ensure that GHC doesn't pick this COMPLETE set, it checks each pattern+synonym constructor's return type matches the type of the scrutinee, and if one+doesn't, then we remove the whole COMPLETE set from consideration.++One might wonder why GHC only checks /pattern synonym/ constructors, and not+/data/ constructors as well. The reason is because that the type of a+GADT constructor very well may not match the type of a scrutinee, and that's+OK. Consider this example (from #14059):++  data SBool (z :: Bool) where+    SFalse :: SBool False+    STrue  :: SBool True++  pattern STooGoodToBeTrue :: forall (z :: Bool). ()+                           => z ~ True+                           => SBool z+  pattern STooGoodToBeTrue = STrue+  {-# COMPLETE SFalse, STooGoodToBeTrue #-}++  wobble :: SBool z -> Bool+  wobble STooGoodToBeTrue = True++In the incomplete pattern match for `wobble`, we /do/ want to warn that SFalse+should be matched against, even though its type, SBool False, does not match+the scrutinee type, SBool z.++SG: Another angle at this is that the implied constraints when we instantiate+universal type variables in the return type of a GADT will lead to *provided*+thetas, whereas when we instantiate the return type of a pattern synonym that+corresponds to a *required* theta. See Note [Pattern synonym result type] in+PatSyn. Note how isValidCompleteMatches will successfully filter out++    pattern Just42 :: Maybe Int+    pattern Just42 = Just 42++But fail to filter out the equivalent++    pattern Just'42 :: (a ~ Int) => Maybe a+    pattern Just'42 = Just 42++Which seems fine as far as tcMatchTy is concerned, but it raises a few eye+brows.+-}++{-+%************************************************************************+%*                                                                      *+            Heart of the algorithm: Function pmCheck+%*                                                                      *+%************************************************************************++Main functions are:++* pmCheck :: PatVec -> [PatVec] -> ValVec -> Delta -> DsM PartialResult++  This function implements functions `covered`, `uncovered` and+  `divergent` from the paper at once. Calls out to the auxilary function+  `pmCheckGuards` for handling (possibly multiple) guarded RHSs when the whole+  clause is checked. Slightly different from the paper because it does not even+  produce the covered and uncovered sets. Since we only care about whether a+  clause covers SOMETHING or if it may forces ANY argument, we only store a+  boolean in both cases, for efficiency.++* pmCheckGuards :: [PatVec] -> ValVec -> Delta -> DsM PartialResult++  Processes the guards.+-}++-- | @throttle limit f n delta@ executes the pattern match action @f@ but+-- replaces the 'Uncovered' set by @[delta]@ if not doing so would lead to+-- too many Deltas to check.+--+-- See Note [Countering exponential blowup] and+-- Note [Combinatorial explosion in guards]+--+-- How many is "too many"? @throttle@ assumes that the pattern match action+-- will be executed against @n@ similar other Deltas, its "siblings". Now, by+-- observing the branching factor (i.e. the number of children) of executing+-- the action, we can estimate how many Deltas there would be in the next+-- generation. If we find that this number exceeds @limit@, we do+-- "birth control": We simply don't allow a branching factor of more than 1.+-- Otherwise we just return the singleton set of the original @delta@.+-- This amounts to forgetting about the refined facts we got from running the+-- action.+throttle :: Int -> (Int -> Delta -> DsM PartialResult) -> Int -> Delta -> DsM (Int, PartialResult)+throttle limit f n_siblings delta = do+  res <- f n_siblings delta+  let n_own_children = length (presultUncovered res)+  let n_next_gen = n_siblings * n_own_children+  -- Birth control!+  if n_next_gen <= limit || n_own_children <= 1+    then pure (n_next_gen, res)+    else pure (n_siblings, res { presultUncovered = [delta], presultApprox = Approximate })++-- | Map a pattern matching action processing a single 'Delta' over a+-- 'Uncovered' set and return the combined 'PartialResult's.+runMany :: (Delta -> DsM PartialResult) -> Uncovered -> DsM PartialResult+runMany f unc = mconcat <$> traverse f unc++-- | Print diagnostic info and actually call 'pmCheck''.+pmCheck :: GrdVec -> [GrdVec] -> Int -> Delta -> DsM PartialResult+pmCheck ps guards n delta = do+  tracePm "pmCheck {" $ vcat [ ppr n <> colon+                           , hang (text "patterns:") 2 (ppr ps)+                           , hang (text "guards:") 2 (ppr guards)+                           , ppr delta ]+  res <- pmCheck' ps guards n delta+  tracePm "}:" (ppr res) -- braces are easier to match by tooling+  return res++-- | Lifts 'pmCheck' over a 'DsM (Maybe Delta)'.+pmCheckM :: GrdVec -> [GrdVec] -> Int -> DsM (Maybe Delta) -> DsM PartialResult+pmCheckM ps guards n m_mb_delta = m_mb_delta >>= \case+  Nothing    -> pure mempty+  Just delta -> pmCheck ps guards n delta++-- | Check the list of mutually exclusive guards+pmCheckGuards :: [GrdVec] -> Int -> Delta -> DsM PartialResult+pmCheckGuards []       _ delta = return (usimple delta)+pmCheckGuards (gv:gvs) n delta = do+  dflags <- getDynFlags+  let limit = maxPmCheckModels dflags `div` 5+  (n', PartialResult cs unc ds pc) <- throttle limit (pmCheck gv []) n delta+  (PartialResult css uncs dss pcs) <- runMany (pmCheckGuards gvs n') unc+  return $ PartialResult (cs `mappend` css)+                         uncs+                         (ds `mappend` dss)+                         (pc `mappend` pcs)++-- | Matching function: Check simultaneously a clause (takes separately the+-- patterns and the list of guards) for exhaustiveness, redundancy and+-- inaccessibility.+pmCheck'+  :: GrdVec   -- ^ Patterns of the clause+  -> [GrdVec] -- ^ (Possibly multiple) guards of the clause+  -> Int      -- ^ Estimate on the number of similar 'Delta's to handle.+              --   See 6. in Note [Countering exponential blowup]+  -> Delta    -- ^ Oracle state giving meaning to the identifiers in the ValVec+  -> DsM PartialResult+pmCheck' [] guards n delta+  | null guards = return $ mempty { presultCovered = Covered }+  | otherwise   = pmCheckGuards guards n delta++-- let x = e: Add x ~ e to the oracle+pmCheck' (PmLet { pm_id = x, pm_let_expr = e } : ps) guards n delta = do+  tracePm "PmLet" (vcat [ppr x, ppr e])+  -- x is fresh because it's bound by the let+  delta' <- expectJust "x is fresh" <$> addVarCoreCt delta x e+  pmCheck ps guards n delta'++-- Bang x: Add x /~ _|_ to the oracle+pmCheck' (PmBang x : ps) guards n delta = do+  tracePm "PmBang" (ppr x)+  pr <- pmCheckM ps guards n (addTmCt delta (TmVarNonVoid x))+  pure (forceIfCanDiverge delta x pr)++-- Con: Add x ~ K ys to the Covered set and x /~ K to the Uncovered set+pmCheck' (p : ps) guards n delta+  | PmCon{ pm_id = x, pm_con_con = con, pm_con_args = args+         , pm_con_dicts = dicts } <- p = do+  -- E.g   f (K p q) = <rhs>+  --       <next equation>+  -- Split delta into two refinements:+  --    * one for <rhs>, binding x to (K p q)+  --    * one for <next equation>, recording that x is /not/ (K _ _)++  -- Stuff for <rhs>+  pr_pos <- pmCheckM ps guards n (addPmConCts delta x con dicts args)++  -- The var is forced regardless of whether @con@ was satisfiable+  -- See Note [Divergence of Newtype matches]+  let pr_pos' = addConMatchStrictness delta x con pr_pos++  -- Stuff for <next equation>+  pr_neg <- addRefutableAltCon delta x con >>= \case+    Nothing     -> pure mempty+    Just delta' -> pure (usimple delta')++  tracePm "PmCon" (vcat [ppr p, ppr x, ppr pr_pos', ppr pr_neg])++  -- Combine both into a single PartialResult+  let pr = mkUnion pr_pos' pr_neg+  pure pr++addPmConCts :: Delta -> Id -> PmAltCon -> [EvVar] -> [Id] -> DsM (Maybe Delta)+addPmConCts delta x con dicts fields = runMaybeT $ do+  delta_ty    <- MaybeT $ addTypeEvidence delta (listToBag dicts)+  delta_tm_ty <- MaybeT $ addTmCt delta_ty (TmVarCon x con fields)+  pure delta_tm_ty++-- ----------------------------------------------------------------------------+-- * Utilities for main checking++-- | Initialise with default values for covering and divergent information and+-- a singleton uncovered set.+usimple :: Delta -> PartialResult+usimple delta = mempty { presultUncovered = [delta] }++-- | Get the union of two covered, uncovered and divergent value set+-- abstractions. Since the covered and divergent sets are represented by a+-- boolean, union means computing the logical or (at least one of the two is+-- non-empty).++mkUnion :: PartialResult -> PartialResult -> PartialResult+mkUnion = mappend++-- | Set the divergent set to not empty+forces :: PartialResult -> PartialResult+forces pres = pres { presultDivergent = Diverged }++-- | Set the divergent set to non-empty if the variable has not been forced yet+forceIfCanDiverge :: Delta -> Id -> PartialResult -> PartialResult+forceIfCanDiverge delta x+  | canDiverge delta x = forces+  | otherwise          = id++-- | 'forceIfCanDiverge' if the 'PmAltCon' was not a Newtype.+-- See Note [Divergence of Newtype matches].+addConMatchStrictness :: Delta -> Id -> PmAltCon -> PartialResult -> PartialResult+addConMatchStrictness _     _ (PmAltConLike (RealDataCon dc)) res+  | isNewTyCon (dataConTyCon dc) = res+addConMatchStrictness delta x _ res = forceIfCanDiverge delta x res++-- ----------------------------------------------------------------------------+-- * Propagation of term constraints inwards when checking nested matches++{- Note [Type and Term Equality Propagation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When checking a match it would be great to have all type and term information+available so we can get more precise results. For this reason we have functions+`addDictsDs' and `addTmVarCsDs' in DsMonad that store in the environment type and+term constraints (respectively) as we go deeper.++The type constraints we propagate inwards are collected by `collectEvVarsPats'+in GHC.Hs.Pat. This handles bug #4139 ( see example+  https://gitlab.haskell.org/ghc/ghc/snippets/672 )+where this is needed.++For term equalities we do less, we just generate equalities for HsCase. For+example we accurately give 2 redundancy warnings for the marked cases:++f :: [a] -> Bool+f x = case x of++  []    -> case x of        -- brings (x ~ []) in scope+             []    -> True+             (_:_) -> False -- can't happen++  (_:_) -> case x of        -- brings (x ~ (_:_)) in scope+             (_:_) -> True+             []    -> False -- can't happen++Functions `addScrutTmCs' and `addPatTmCs' are responsible for generating+these constraints.+-}++locallyExtendPmDelta :: (Delta -> DsM (Maybe Delta)) -> DsM a -> DsM a+locallyExtendPmDelta ext k = getPmDelta >>= ext >>= \case+  -- If adding a constraint would lead to a contradiction, don't add it.+  -- See @Note [Recovering from unsatisfiable pattern-matching constraints]@+  -- for why this is done.+  Nothing     -> k+  Just delta' -> updPmDelta delta' k++-- | Add in-scope type constraints+addTyCsDs :: Bag EvVar -> DsM a -> DsM a+addTyCsDs ev_vars =+  locallyExtendPmDelta (\delta -> addTypeEvidence delta ev_vars)++-- | Add equalities for the scrutinee to the local 'DsM' environment when+-- checking a case expression:+--     case e of x { matches }+-- When checking matches we record that (x ~ e) where x is the initial+-- uncovered. All matches will have to satisfy this equality.+addScrutTmCs :: Maybe (LHsExpr GhcTc) -> [Id] -> DsM a -> DsM a+addScrutTmCs Nothing    _   k = k+addScrutTmCs (Just scr) [x] k = do+  scr_e <- dsLExpr scr+  locallyExtendPmDelta (\delta -> addVarCoreCt delta x scr_e) k+addScrutTmCs _   _   _ = panic "addScrutTmCs: HsCase with more than one case binder"++-- | Add equalities to the local 'DsM' environment when checking the RHS of a+-- case expression:+--     case e of x { p1 -> e1; ... pn -> en }+-- When we go deeper to check e.g. e1 we record (x ~ p1).+addPatTmCs :: [Pat GhcTc]           -- LHS       (should have length 1)+           -> [Id]                  -- MatchVars (should have length 1)+           -> DsM a+           -> DsM a+-- Computes an approximation of the Covered set for p1 (which pmCheck currently+-- discards).+addPatTmCs ps xs k = do+  fam_insts <- dsGetFamInstEnvs+  grds <- concat <$> zipWithM (translatePat fam_insts) xs ps+  locallyExtendPmDelta (\delta -> computeCovered grds delta) k++-- | A dead simple version of 'pmCheck' that only computes the Covered set.+-- So it only cares about collecting positive info.+-- We use it to collect info from a pattern when we check its RHS.+-- See 'addPatTmCs'.+computeCovered :: GrdVec -> Delta -> DsM (Maybe Delta)+-- The duplication with 'pmCheck' is really unfortunate, but it's simpler than+-- separating out the common cases with 'pmCheck', because that would make the+-- ConVar case harder to understand.+computeCovered [] delta = pure (Just delta)+computeCovered (PmLet { pm_id = x, pm_let_expr = e } : ps) delta = do+  delta' <- expectJust "x is fresh" <$> addVarCoreCt delta x e+  computeCovered ps delta'+computeCovered (PmBang{} : ps) delta = do+  computeCovered ps delta+computeCovered (p : ps) delta+  | PmCon{ pm_id = x, pm_con_con = con, pm_con_args = args+         , pm_con_dicts = dicts } <- p+  = addPmConCts delta x con dicts args >>= \case+      Nothing     -> pure Nothing+      Just delta' -> computeCovered ps delta'++{-+%************************************************************************+%*                                                                      *+      Pretty printing of exhaustiveness/redundancy check warnings+%*                                                                      *+%************************************************************************+-}++-- | Check whether any part of pattern match checking is enabled for this+-- 'HsMatchContext' (does not matter whether it is the redundancy check or the+-- exhaustiveness check).+isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext id -> Bool+isMatchContextPmChecked dflags origin kind+  | isGenerated origin+  = False+  | otherwise+  = wopt Opt_WarnOverlappingPatterns dflags || exhaustive dflags kind++-- | Return True when any of the pattern match warnings ('allPmCheckWarnings')+-- are enabled, in which case we need to run the pattern match checker.+needToRunPmCheck :: DynFlags -> Origin -> Bool+needToRunPmCheck dflags origin+  | isGenerated origin+  = False+  | otherwise+  = notNull (filter (`wopt` dflags) allPmCheckWarnings)++-- | Issue all the warnings (coverage, exhaustiveness, inaccessibility)+dsPmWarn :: DynFlags -> DsMatchContext -> [Id] -> PmResult -> DsM ()+dsPmWarn dflags ctx@(DsMatchContext kind loc) vars pm_result+  = when (flag_i || flag_u) $ do+      let exists_r = flag_i && notNull redundant+          exists_i = flag_i && notNull inaccessible && not is_rec_upd+          exists_u = flag_u && notNull uncovered+          approx   = precision == Approximate++      when (approx && (exists_u || exists_i)) $+        putSrcSpanDs loc (warnDs NoReason approx_msg)++      when exists_r $ forM_ redundant $ \(dL->L l q) -> do+        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)+                               (pprEqn q "is redundant"))+      when exists_i $ forM_ inaccessible $ \(dL->L l q) -> do+        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)+                               (pprEqn q "has inaccessible right hand side"))+      when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $+        pprEqns vars uncovered+  where+    PmResult+      { pmresultRedundant = redundant+      , pmresultUncovered = uncovered+      , pmresultInaccessible = inaccessible+      , pmresultApproximate = precision } = pm_result++    flag_i = wopt Opt_WarnOverlappingPatterns dflags+    flag_u = exhaustive dflags kind+    flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind)++    is_rec_upd = case kind of { RecUpd -> True; _ -> False }+       -- See Note [Inaccessible warnings for record updates]++    maxPatterns = maxUncoveredPatterns dflags++    -- Print a single clause (for redundant/with-inaccessible-rhs)+    pprEqn q txt = pprContext True ctx (text txt) $ \f ->+      f (pprPats kind (map unLoc q))++    -- Print several clauses (for uncovered clauses)+    pprEqns vars deltas = pprContext False ctx (text "are non-exhaustive") $ \_ ->+      case vars of -- See #11245+           [] -> text "Guards do not cover entire pattern space"+           _  -> let us = map (\delta -> pprUncovered delta vars) deltas+                 in  hang (text "Patterns not matched:") 4+                       (vcat (take maxPatterns us) $$ dots maxPatterns us)++    approx_msg = vcat+      [ hang+          (text "Pattern match checker ran into -fmax-pmcheck-models="+            <> int (maxPmCheckModels dflags)+            <> text " limit, so")+          2+          (  bullet <+> text "Redundant clauses might not be reported at all"+          $$ bullet <+> text "Redundant clauses might be reported as inaccessible"+          $$ bullet <+> text "Patterns reported as unmatched might actually be matched")+      , text "Increase the limit or resolve the warnings to suppress this message." ]++{- Note [Inaccessible warnings for record updates]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#12957)+  data T a where+    T1 :: { x :: Int } -> T Bool+    T2 :: { x :: Int } -> T a+    T3 :: T a++  f :: T Char -> T a+  f r = r { x = 3 }++The desugarer will (conservatively generate a case for T1 even though+it's impossible:+  f r = case r of+          T1 x -> T1 3   -- Inaccessible branch+          T2 x -> T2 3+          _    -> error "Missing"++We don't want to warn about the inaccessible branch because the programmer+didn't put it there!  So we filter out the warning here.+-}++dots :: Int -> [a] -> SDoc+dots maxPatterns qs+    | qs `lengthExceeds` maxPatterns = text "..."+    | otherwise                      = empty++-- | All warning flags that need to run the pattern match checker.+allPmCheckWarnings :: [WarningFlag]+allPmCheckWarnings =+  [ Opt_WarnIncompletePatterns+  , Opt_WarnIncompleteUniPatterns+  , Opt_WarnIncompletePatternsRecUpd+  , Opt_WarnOverlappingPatterns+  ]++-- | Check whether the exhaustiveness checker should run (exhaustiveness only)+exhaustive :: DynFlags -> HsMatchContext id -> Bool+exhaustive  dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag++-- | Denotes whether an exhaustiveness check is supported, and if so,+-- via which 'WarningFlag' it's controlled.+-- Returns 'Nothing' if check is not supported.+exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag+exhaustiveWarningFlag (FunRhs {})   = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag CaseAlt       = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag IfAlt         = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag LambdaExpr    = Just Opt_WarnIncompleteUniPatterns+exhaustiveWarningFlag PatBindRhs    = Just Opt_WarnIncompleteUniPatterns+exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag ProcExpr      = Just Opt_WarnIncompleteUniPatterns+exhaustiveWarningFlag RecUpd        = Just Opt_WarnIncompletePatternsRecUpd+exhaustiveWarningFlag ThPatSplice   = Nothing+exhaustiveWarningFlag PatSyn        = Nothing+exhaustiveWarningFlag ThPatQuote    = Nothing+exhaustiveWarningFlag (StmtCtxt {}) = Nothing -- Don't warn about incomplete patterns+                                       -- in list comprehensions, pattern guards+                                       -- etc. They are often *supposed* to be+                                       -- incomplete++-- True <==> singular+pprContext :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc+pprContext singular (DsMatchContext kind _loc) msg rest_of_msg_fun+  = vcat [text txt <+> msg,+          sep [ text "In" <+> ppr_match <> char ':'+              , nest 4 (rest_of_msg_fun pref)]]+  where+    txt | singular  = "Pattern match"+        | otherwise = "Pattern match(es)"++    (ppr_match, pref)+        = case kind of+             FunRhs { mc_fun = (dL->L _ fun) }+                  -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)+             _    -> (pprMatchContext kind, \ pp -> pp)++pprPats :: HsMatchContext Name -> [Pat GhcTc] -> SDoc+pprPats kind pats+  = sep [sep (map ppr pats), matchSeparator kind, text "..."]
+ compiler/GHC/HsToCore/PmCheck/Oracle.hs view
@@ -0,0 +1,1651 @@+{-+Authors: George Karachalias <george.karachalias@cs.kuleuven.be>+         Sebastian Graf <sgraf1337@gmail.com>+         Ryan Scott <ryan.gl.scott@gmail.com>+-}++{-# LANGUAGE CPP, LambdaCase, TupleSections, PatternSynonyms, ViewPatterns, MultiWayIf #-}++-- | The pattern match oracle. The main export of the module are the functions+-- 'addTmCt', 'addVarCoreCt', 'addRefutableAltCon' and 'addTypeEvidence' for+-- adding facts to the oracle, and 'provideEvidence' to turn a+-- 'Delta' into a concrete evidence for an equation.+module GHC.HsToCore.PmCheck.Oracle (++        DsM, tracePm, mkPmId,+        Delta, initDelta, lookupRefuts, lookupSolution,++        TmCt(..),+        addTypeEvidence,    -- Add type equalities+        addRefutableAltCon, -- Add a negative term equality+        addTmCt,            -- Add a positive term equality x ~ e+        addVarCoreCt,       -- Add a positive term equality x ~ core_expr+        canDiverge,         -- Try to add the term equality x ~ ⊥+        provideEvidence,+    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.HsToCore.PmCheck.Types++import DynFlags+import Outputable+import ErrUtils+import Util+import Bag+import UniqSet+import UniqDSet+import Unique+import Id+import VarEnv+import UniqDFM+import Var           (EvVar)+import Name+import CoreSyn+import CoreFVs ( exprFreeVars )+import CoreMap+import CoreOpt (simpleOptExpr, exprIsConApp_maybe)+import CoreUtils (exprType)+import MkCore (mkListExpr, mkCharExpr)+import UniqSupply+import FastString+import SrcLoc+import ListSetOps (unionLists)+import Maybes+import ConLike+import DataCon+import PatSyn+import TyCon+import TysWiredIn+import TysPrim (tYPETyCon)+import TyCoRep+import Type+import TcSimplify    (tcNormalise, tcCheckSatisfiability)+import TcType        (evVarPred)+import Unify         (tcMatchTy)+import TcRnTypes     (completeMatchConLikes)+import Coercion+import MonadUtils hiding (foldlM)+import DsMonad hiding (foldlM)+import FamInst+import FamInstEnv++import Control.Monad (guard, mzero)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State.Strict+import Data.Bifunctor (second)+import Data.Foldable (foldlM, minimumBy)+import Data.List     (find)+import qualified Data.List.NonEmpty as NonEmpty+import Data.Ord      (comparing)+import qualified Data.Semigroup as Semigroup+import Data.Tuple    (swap)++-- Debugging Infrastructre++tracePm :: String -> SDoc -> DsM ()+tracePm herald doc = do+  dflags <- getDynFlags+  printer <- mkPrintUnqualifiedDs+  liftIO $ dumpIfSet_dyn_printer printer dflags+            Opt_D_dump_ec_trace (text herald $$ (nest 2 doc))++-- | Generate a fresh `Id` of a given type+mkPmId :: Type -> DsM Id+mkPmId ty = getUniqueM >>= \unique ->+  let occname = mkVarOccFS $ fsLit "pm"+      name    = mkInternalName unique occname noSrcSpan+  in  return (mkLocalId name ty)++-----------------------------------------------+-- * Caching possible matches of a COMPLETE set++markMatched :: ConLike -> PossibleMatches -> PossibleMatches+markMatched _   NoPM    = NoPM+markMatched con (PM ms) = PM (del_one_con con <$> ms)+  where+    del_one_con = flip delOneFromUniqDSet++---------------------------------------------------+-- * Instantiating constructors, types and evidence++-- | Instantiate a 'ConLike' given its universal type arguments. Instantiates+-- existential and term binders with fresh variables of appropriate type.+-- Returns instantiated term variables from the match, type evidence and the+-- types of strict constructor fields.+mkOneConFull :: [Type] -> ConLike -> DsM ([Id], Bag TyCt, [Type])+--  * 'con' K is a ConLike+--       - In the case of DataCons and most PatSynCons, these+--         are associated with a particular TyCon T+--       - But there are PatSynCons for this is not the case! See #11336, #17112+--+--  * 'arg_tys' tys are the types K's universally quantified type+--     variables should be instantiated to.+--       - For DataCons and most PatSyns these are the arguments of their TyCon+--       - For cases like the PatSyns in #11336, #17112, we can't easily guess+--         these, so don't call this function.+--+-- After instantiating the universal tyvars of K to tys we get+--          K @tys :: forall bs. Q => s1 .. sn -> T tys+-- Note that if K is a PatSynCon, depending on arg_tys, T might not necessarily+-- be a concrete TyCon.+--+-- Suppose y1 is a strict field. Then we get+-- Results: [y1,..,yn]+--          Q+--          [s1]+mkOneConFull arg_tys con = do+  let (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , field_tys, _con_res_ty)+        = conLikeFullSig con+  -- pprTrace "mkOneConFull" (ppr con $$ ppr arg_tys $$ ppr univ_tvs $$ ppr _con_res_ty) (return ())+  -- Substitute universals for type arguments+  let subst_univ = zipTvSubst univ_tvs arg_tys+  -- Instantiate fresh existentials as arguments to the contructor. This is+  -- important for instantiating the Thetas and field types.+  (subst, _) <- cloneTyVarBndrs subst_univ ex_tvs <$> getUniqueSupplyM+  let field_tys' = substTys subst field_tys+  -- Instantiate fresh term variables (VAs) as arguments to the constructor+  vars <- mapM mkPmId field_tys'+  -- All constraints bound by the constructor (alpha-renamed), these are added+  -- to the type oracle+  let ty_cs = map TyCt (substTheta subst (eqSpecPreds eq_spec ++ thetas))+  -- Figure out the types of strict constructor fields+  let arg_is_strict+        | RealDataCon dc <- con+        , isNewTyCon (dataConTyCon dc)+        = [True] -- See Note [Divergence of Newtype matches]+        | otherwise+        = map isBanged $ conLikeImplBangs con+      strict_arg_tys = filterByList arg_is_strict field_tys'+  return (vars, listToBag ty_cs, strict_arg_tys)++-------------------------+-- * Pattern match oracle+++{- Note [Recovering from unsatisfiable pattern-matching constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following code (see #12957 and #15450):++  f :: Int ~ Bool => ()+  f = case True of { False -> () }++We want to warn that the pattern-matching in `f` is non-exhaustive. But GHC+used not to do this; in fact, it would warn that the match was /redundant/!+This is because the constraint (Int ~ Bool) in `f` is unsatisfiable, and the+coverage checker deems any matches with unsatifiable constraint sets to be+unreachable.++We decide to better than this. When beginning coverage checking, we first+check if the constraints in scope are unsatisfiable, and if so, we start+afresh with an empty set of constraints. This way, we'll get the warnings+that we expect.+-}++-------------------------------------+-- * Composable satisfiability checks++-- | Given a 'Delta', check if it is compatible with new facts encoded in this+-- this check. If so, return 'Just' a potentially extended 'Delta'. Return+-- 'Nothing' if unsatisfiable.+--+-- There are three essential SatisfiabilityChecks:+--   1. 'tmIsSatisfiable', adding term oracle facts+--   2. 'tyIsSatisfiable', adding type oracle facts+--   3. 'tysAreNonVoid', checks if the given types have an inhabitant+-- Functions like 'pmIsSatisfiable', 'nonVoid' and 'testInhabited' plug these+-- together as they see fit.+newtype SatisfiabilityCheck = SC (Delta -> DsM (Maybe Delta))++-- | Check the given 'Delta' for satisfiability by the the given+-- 'SatisfiabilityCheck'. Return 'Just' a new, potentially extended, 'Delta' if+-- successful, and 'Nothing' otherwise.+runSatisfiabilityCheck :: Delta -> SatisfiabilityCheck -> DsM (Maybe Delta)+runSatisfiabilityCheck delta (SC chk) = chk delta++-- | Allowing easy composition of 'SatisfiabilityCheck's.+instance Semigroup SatisfiabilityCheck where+  -- This is @a >=> b@ from MaybeT DsM+  SC a <> SC b = SC c+    where+      c delta = a delta >>= \case+        Nothing     -> pure Nothing+        Just delta' -> b delta'++instance Monoid SatisfiabilityCheck where+  -- We only need this because of mconcat (which we use in place of sconcat,+  -- which requires NonEmpty lists as argument, making all call sites ugly)+  mempty = SC (pure . Just)++-------------------------------+-- * Oracle transition function++-- | Given a conlike's term constraints, type constraints, and strict argument+-- types, check if they are satisfiable.+-- (In other words, this is the ⊢_Sat oracle judgment from the GADTs Meet+-- Their Match paper.)+--+-- Taking strict argument types into account is something which was not+-- discussed in GADTs Meet Their Match. For an explanation of what role they+-- serve, see @Note [Strict argument type constraints]@.+pmIsSatisfiable+  :: Delta       -- ^ The ambient term and type constraints+                 --   (known to be satisfiable).+  -> Bag TmCt    -- ^ The new term constraints.+  -> Bag TyCt    -- ^ The new type constraints.+  -> [Type]      -- ^ The strict argument types.+  -> DsM (Maybe Delta)+                 -- ^ @'Just' delta@ if the constraints (@delta@) are+                 -- satisfiable, and each strict argument type is inhabitable.+                 -- 'Nothing' otherwise.+pmIsSatisfiable amb_cs new_tm_cs new_ty_cs strict_arg_tys =+  -- The order is important here! Check the new type constraints before we check+  -- whether strict argument types are inhabited given those constraints.+  runSatisfiabilityCheck amb_cs $ mconcat+    [ tyIsSatisfiable True new_ty_cs+    , tmIsSatisfiable new_tm_cs+    , tysAreNonVoid initRecTc strict_arg_tys+    ]++-----------------------+-- * Type normalisation++-- | The return value of 'pmTopNormaliseType'+data TopNormaliseTypeResult+  = NoChange Type+  -- ^ 'tcNormalise' failed to simplify the type and 'topNormaliseTypeX' was+  -- unable to reduce the outermost type application, so the type came out+  -- unchanged.+  | NormalisedByConstraints Type+  -- ^ 'tcNormalise' was able to simplify the type with some local constraint+  -- from the type oracle, but 'topNormaliseTypeX' couldn't identify a type+  -- redex.+  | HadRedexes Type [(Type, DataCon, Type)] Type+  -- ^ 'tcNormalise' may or may not been able to simplify the type, but+  -- 'topNormaliseTypeX' made progress either way and got rid of at least one+  -- outermost type or data family redex or newtype.+  -- The first field is the last type that was reduced solely through type+  -- family applications (possibly just the 'tcNormalise'd type). This is the+  -- one that is equal (in source Haskell) to the initial type.+  -- The third field is the type that we get when also looking through data+  -- family applications and newtypes. This would be the representation type in+  -- Core (modulo casts).+  -- The second field is the list of Newtype 'DataCon's that we looked through+  -- in the chain of reduction steps between the Source type and the Core type.+  -- We also keep the type of the DataCon application and its field, so that we+  -- don't have to reconstruct it in 'inhabitationCandidates' and+  -- 'provideEvidence'.+  -- For an example, see Note [Type normalisation].++-- | Just give me the potentially normalised source type, unchanged or not!+normalisedSourceType :: TopNormaliseTypeResult -> Type+normalisedSourceType (NoChange ty)                = ty+normalisedSourceType (NormalisedByConstraints ty) = ty+normalisedSourceType (HadRedexes ty _ _)          = ty++-- | Return the fields of 'HadRedexes'. Returns appropriate defaults in the+-- other cases.+tntrGuts :: TopNormaliseTypeResult -> (Type, [(Type, DataCon, Type)], Type)+tntrGuts (NoChange ty)                  = (ty,     [],      ty)+tntrGuts (NormalisedByConstraints ty)   = (ty,     [],      ty)+tntrGuts (HadRedexes src_ty ds core_ty) = (src_ty, ds, core_ty)++instance Outputable TopNormaliseTypeResult where+  ppr (NoChange ty)                  = text "NoChange" <+> ppr ty+  ppr (NormalisedByConstraints ty)   = text "NormalisedByConstraints" <+> ppr ty+  ppr (HadRedexes src_ty ds core_ty) = text "HadRedexes" <+> braces fields+    where+      fields = fsep (punctuate comma [ text "src_ty =" <+> ppr src_ty+                                     , text "newtype_dcs =" <+> ppr ds+                                     , text "core_ty =" <+> ppr core_ty ])++pmTopNormaliseType :: TyState -> Type -> DsM TopNormaliseTypeResult+-- ^ Get rid of *outermost* (or toplevel)+--      * type function redex+--      * data family redex+--      * newtypes+--+-- Behaves like `topNormaliseType_maybe`, but instead of returning a+-- coercion, it returns useful information for issuing pattern matching+-- warnings. See Note [Type normalisation] for details.+-- It also initially 'tcNormalise's the type with the bag of local constraints.+--+-- See 'TopNormaliseTypeResult' for the meaning of the return value.+--+-- NB: Normalisation can potentially change kinds, if the head of the type+-- is a type family with a variable result kind. I (Richard E) can't think+-- of a way to cause trouble here, though.+pmTopNormaliseType (TySt inert) typ+  = do env <- dsGetFamInstEnvs+       -- Before proceeding, we chuck typ into the constraint solver, in case+       -- solving for given equalities may reduce typ some. See+       -- "Wrinkle: local equalities" in Note [Type normalisation].+       (_, mb_typ') <- initTcDsForSolver $ tcNormalise inert typ+       -- If tcNormalise didn't manage to simplify the type, continue anyway.+       -- We might be able to reduce type applications nonetheless!+       let typ' = fromMaybe typ mb_typ'+       -- Now we look with topNormaliseTypeX through type and data family+       -- applications and newtypes, which tcNormalise does not do.+       -- See also 'TopNormaliseTypeResult'.+       pure $ case topNormaliseTypeX (stepper env) comb typ' of+         Nothing+           | Nothing <- mb_typ' -> NoChange typ+           | otherwise          -> NormalisedByConstraints typ'+         Just ((ty_f,tm_f), ty) -> HadRedexes src_ty newtype_dcs core_ty+           where+             src_ty = eq_src_ty ty (typ' : ty_f [ty])+             newtype_dcs = tm_f []+             core_ty = ty+  where+    -- Find the first type in the sequence of rewrites that is a data type,+    -- newtype, or a data family application (not the representation tycon!).+    -- This is the one that is equal (in source Haskell) to the initial type.+    -- If none is found in the list, then all of them are type family+    -- applications, so we simply return the last one, which is the *simplest*.+    eq_src_ty :: Type -> [Type] -> Type+    eq_src_ty ty tys = maybe ty id (find is_closed_or_data_family tys)++    is_closed_or_data_family :: Type -> Bool+    is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyAppType ty++    -- For efficiency, represent both lists as difference lists.+    -- comb performs the concatenation, for both lists.+    comb (tyf1, tmf1) (tyf2, tmf2) = (tyf1 . tyf2, tmf1 . tmf2)++    stepper env = newTypeStepper `composeSteppers` tyFamStepper env++    -- A 'NormaliseStepper' that unwraps newtypes, careful not to fall into+    -- a loop. If it would fall into a loop, it produces 'NS_Abort'.+    newTypeStepper :: NormaliseStepper ([Type] -> [Type],[(Type, DataCon, Type)] -> [(Type, DataCon, Type)])+    newTypeStepper rec_nts tc tys+      | Just (ty', _co) <- instNewTyCon_maybe tc tys+      , let orig_ty = TyConApp tc tys+      = case checkRecTc rec_nts tc of+          Just rec_nts' -> let tyf = (orig_ty:)+                               tmf = ((orig_ty, tyConSingleDataCon tc, ty'):)+                           in  NS_Step rec_nts' ty' (tyf, tmf)+          Nothing       -> NS_Abort+      | otherwise+      = NS_Done++    tyFamStepper :: FamInstEnvs -> NormaliseStepper ([Type] -> [Type], a -> a)+    tyFamStepper env rec_nts tc tys  -- Try to step a type/data family+      = let (_args_co, ntys, _res_co) = normaliseTcArgs env Representational tc tys in+          -- NB: It's OK to use normaliseTcArgs here instead of+          -- normalise_tc_args (which takes the LiftingContext described+          -- in Note [Normalising types]) because the reduceTyFamApp below+          -- works only at top level. We'll never recur in this function+          -- after reducing the kind of a bound tyvar.++        case reduceTyFamApp_maybe env Representational tc ntys of+          Just (_co, rhs) -> NS_Step rec_nts rhs ((rhs:), id)+          _               -> NS_Done++-- | Returns 'True' if the argument 'Type' is a fully saturated application of+-- a closed type constructor.+--+-- Closed type constructors are those with a fixed right hand side, as+-- opposed to e.g. associated types. These are of particular interest for+-- pattern-match coverage checking, because GHC can exhaustively consider all+-- possible forms that values of a closed type can take on.+--+-- Note that this function is intended to be used to check types of value-level+-- patterns, so as a consequence, the 'Type' supplied as an argument to this+-- function should be of kind @Type@.+pmIsClosedType :: Type -> Bool+pmIsClosedType ty+  = case splitTyConApp_maybe ty of+      Just (tc, ty_args)+             | is_algebraic_like tc && not (isFamilyTyCon tc)+             -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True+      _other -> False+  where+    -- This returns True for TyCons which /act like/ algebraic types.+    -- (See "Type#type_classification" for what an algebraic type is.)+    --+    -- This is qualified with \"like\" because of a particular special+    -- case: TYPE (the underlyind kind behind Type, among others). TYPE+    -- is conceptually a datatype (and thus algebraic), but in practice it is+    -- a primitive builtin type, so we must check for it specially.+    --+    -- NB: it makes sense to think of TYPE as a closed type in a value-level,+    -- pattern-matching context. However, at the kind level, TYPE is certainly+    -- not closed! Since this function is specifically tailored towards pattern+    -- matching, however, it's OK to label TYPE as closed.+    is_algebraic_like :: TyCon -> Bool+    is_algebraic_like tc = isAlgTyCon tc || tc == tYPETyCon++{- Note [Type normalisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Constructs like -XEmptyCase or a previous unsuccessful pattern match on a data+constructor place a non-void constraint on the matched thing. This means that it+boils down to checking whether the type of the scrutinee is inhabited. Function+pmTopNormaliseType gets rid of the outermost type function/data family redex and+newtypes, in search of an algebraic type constructor, which is easier to check+for inhabitation.++It returns 3 results instead of one, because there are 2 subtle points:+1. Newtypes are isomorphic to the underlying type in core but not in the source+   language,+2. The representational data family tycon is used internally but should not be+   shown to the user++Hence, if pmTopNormaliseType env ty_cs ty = Just (src_ty, dcs, core_ty),+then+  (a) src_ty is the rewritten type which we can show to the user. That is, the+      type we get if we rewrite type families but not data families or+      newtypes.+  (b) dcs is the list of newtype constructors "skipped", every time we normalise+      a newtype to its core representation, we keep track of the source data+      constructor. For convenienve, we also track the type we unwrap and the+      type of its field. Example: @Down 42@ => @[(Down @Int, Down, Int)]+  (c) core_ty is the rewritten type. That is,+        pmTopNormaliseType env ty_cs ty = Just (src_ty, dcs, core_ty)+      implies+        topNormaliseType_maybe env ty = Just (co, core_ty)+      for some coercion co.++To see how all cases come into play, consider the following example:++  data family T a :: *+  data instance T Int = T1 | T2 Bool+  -- Which gives rise to FC:+  --   data T a+  --   data R:TInt = T1 | T2 Bool+  --   axiom ax_ti : T Int ~R R:TInt++  newtype G1 = MkG1 (T Int)+  newtype G2 = MkG2 G1++  type instance F Int  = F Char+  type instance F Char = G2++In this case pmTopNormaliseType env ty_cs (F Int) results in++  Just (G2, [(G2,MkG2,G1),(G1,MkG1,T Int)], R:TInt)++Which means that in source Haskell:+  - G2 is equivalent to F Int (in contrast, G1 isn't).+  - if (x : R:TInt) then (MkG2 (MkG1 x) : F Int).++-----+-- Wrinkle: Local equalities+-----++Given the following type family:++  type family F a+  type instance F Int = Void++Should the following program (from #14813) be considered exhaustive?++  f :: (i ~ Int) => F i -> a+  f x = case x of {}++You might think "of course, since `x` is obviously of type Void". But the+idType of `x` is technically F i, not Void, so if we pass F i to+inhabitationCandidates, we'll mistakenly conclude that `f` is non-exhaustive.+In order to avoid this pitfall, we need to normalise the type passed to+pmTopNormaliseType, using the constraint solver to solve for any local+equalities (such as i ~ Int) that may be in scope.+-}++----------------+-- * Type oracle++-- | Wraps a 'PredType', which is a constraint type.+newtype TyCt = TyCt PredType++instance Outputable TyCt where+  ppr (TyCt pred_ty) = ppr pred_ty++-- | Allocates a fresh 'EvVar' name for 'PredTyCt's, or simply returns the+-- wrapped 'EvVar' for 'EvVarTyCt's.+nameTyCt :: TyCt -> DsM EvVar+nameTyCt (TyCt pred_ty) = do+  unique <- getUniqueM+  let occname = mkVarOccFS (fsLit ("pm_"++show unique))+      idname  = mkInternalName unique occname noSrcSpan+  return (mkLocalId idname pred_ty)++-- | Add some extra type constraints to the 'TyState'; return 'Nothing' if we+-- find a contradiction (e.g. @Int ~ Bool@).+tyOracle :: TyState -> Bag TyCt -> DsM (Maybe TyState)+tyOracle (TySt inert) cts+  = do { evs <- traverse nameTyCt cts+       ; let new_inert = inert `unionBags` evs+       ; tracePm "tyOracle" (ppr cts)+       ; ((_warns, errs), res) <- initTcDsForSolver $ tcCheckSatisfiability new_inert+       ; case res of+            -- Note how this implicitly gives all former PredTyCts a name, so+            -- that we don't needlessly re-allocate them every time!+            Just True  -> return (Just (TySt new_inert))+            Just False -> return Nothing+            Nothing    -> pprPanic "tyOracle" (vcat $ pprErrMsgBagWithLoc errs) }++-- | A 'SatisfiabilityCheck' based on new type-level constraints.+-- Returns a new 'Delta' if the new constraints are compatible with existing+-- ones. Doesn't bother calling out to the type oracle if the bag of new type+-- constraints was empty. Will only recheck 'PossibleMatches' in the term oracle+-- for emptiness if the first argument is 'True'.+tyIsSatisfiable :: Bool -> Bag TyCt -> SatisfiabilityCheck+tyIsSatisfiable recheck_complete_sets new_ty_cs = SC $ \delta ->+  if isEmptyBag new_ty_cs+    then pure (Just delta)+    else tyOracle (delta_ty_st delta) new_ty_cs >>= \case+      Nothing                   -> pure Nothing+      Just ty_st'               -> do+        let delta' = delta{ delta_ty_st = ty_st' }+        if recheck_complete_sets+          then ensureAllPossibleMatchesInhabited delta'+          else pure (Just delta')+++{- *********************************************************************+*                                                                      *+              DIdEnv with sharing+*                                                                      *+********************************************************************* -}+++{- *********************************************************************+*                                                                      *+                 TmState+          What we know about terms+*                                                                      *+********************************************************************* -}++{- Note [The Pos/Neg invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Invariant applying to each VarInfo: Whenever we have @(C, [y,z])@ in 'vi_pos',+any entry in 'vi_neg' must be incomparable to C (return Nothing) according to+'eqPmAltCons'. Those entries that are comparable either lead to a refutation+or are redudant. Examples:+* @x ~ Just y@, @x /~ [Just]@. 'eqPmAltCon' returns @Equal@, so refute.+* @x ~ Nothing@, @x /~ [Just]@. 'eqPmAltCon' returns @Disjoint@, so negative+  info is redundant and should be discarded.+* @x ~ I# y@, @x /~ [4,2]@. 'eqPmAltCon' returns @PossiblyOverlap@, so orthogal.+  We keep this info in order to be able to refute a redundant match on i.e. 4+  later on.++This carries over to pattern synonyms and overloaded literals. Say, we have+    pattern Just42 = Just 42+    case Just42 of x+      Nothing -> ()+      Just _  -> ()+Even though we had a solution for the value abstraction called x here in form+of a PatSynCon (Just42,[]), this solution is incomparable to both Nothing and+Just. Hence we retain the info in vi_neg, which eventually allows us to detect+the complete pattern match.++The Pos/Neg invariant extends to vi_cache, which stores essentially positive+information. We make sure that vi_neg and vi_cache never overlap. This isn't+strictly necessary since vi_cache is just a cache, so doesn't need to be+accurate: Every suggestion of a possible ConLike from vi_cache might be+refutable by the type oracle anyway. But it helps to maintain sanity while+debugging traces.++Note [Why record both positive and negative info?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+You might think that knowing positive info (like x ~ Just y) would render+negative info irrelevant, but not so because of pattern synonyms.  E.g we might+know that x cannot match (Foo 4), where pattern Foo p = Just p++Also overloaded literals themselves behave like pattern synonyms. E.g if+postively we know that (x ~ I# y), we might also negatively want to record that+x does not match 45 f 45       = e2 f (I# 22#) = e3 f 45       = e4  --+Overlapped++Note [TmState invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~+The term oracle state is never obviously (i.e., without consulting the type+oracle) contradictory. This implies a few invariants:+* Whenever vi_pos overlaps with vi_neg according to 'eqPmAltCon', we refute.+  This is implied by the Note [Pos/Neg invariant].+* Whenever vi_neg subsumes a COMPLETE set, we refute. We consult vi_cache to+  detect this, but we could just compare whole COMPLETE sets to vi_neg every+  time, if it weren't for performance.++Maintaining these invariants in 'addVarVarCt' (the core of the term oracle) and+'addRefutableAltCon' is subtle.+* Merging VarInfos. Example: Add the fact @x ~ y@ (see 'equate').+  - (COMPLETE) If we had @x /~ True@ and @y /~ False@, then we get+    @x /~ [True,False]@. This is vacuous by matter of comparing to the built-in+    COMPLETE set, so should refute.+  - (Pos/Neg) If we had @x /~ True@ and @y ~ True@, we have to refute.+* Adding positive information. Example: Add the fact @x ~ K ys@ (see 'addVarConCt')+  - (Neg) If we had @x /~ K@, refute.+  - (Pos) If we had @x ~ K2@, and that contradicts the new solution according to+    'eqPmAltCon' (ex. K2 is [] and K is (:)), then refute.+  - (Refine) If we had @x /~ K zs@, unify each y with each z in turn.+* Adding negative information. Example: Add the fact @x /~ Nothing@ (see 'addRefutableAltCon')+  - (Refut) If we have @x ~ K ys@, refute.+  - (Redundant) If we have @x ~ K2@ and @eqPmAltCon K K2 == Disjoint@+    (ex. Just and Nothing), the info is redundant and can be+    discarded.+  - (COMPLETE) If K=Nothing and we had @x /~ Just@, then we get+    @x /~ [Just,Nothing]@. This is vacuous by matter of comparing to the built-in+    COMPLETE set, so should refute.++Note that merging VarInfo in equate can be done by calling out to 'addVarConCt' and+'addRefutableAltCon' for each of the facts individually.++Note [Representation of Strings in TmState]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Instead of treating regular String literals as a PmLits, we treat it as a list+of characters in the oracle for better overlap reasoning. The following example+shows why:++  f :: String -> ()+  f ('f':_) = ()+  f "foo"   = ()+  f _       = ()++The second case is redundant, and we like to warn about it. Therefore either+the oracle will have to do some smart conversion between the list and literal+representation or treat is as the list it really is at runtime.++The "smart conversion" has the advantage of leveraging the more compact literal+representation wherever possible, but is really nasty to get right with negative+equalities: Just think of how to encode @x /= "foo"@.+The "list" option is far simpler, but incurs some overhead in representation and+warning messages (which can be alleviated by someone with enough dedication).+-}++-- | A 'SatisfiabilityCheck' based on new term-level constraints.+-- Returns a new 'Delta' if the new constraints are compatible with existing+-- ones.+tmIsSatisfiable :: Bag TmCt -> SatisfiabilityCheck+tmIsSatisfiable new_tm_cs = SC $ \delta -> runMaybeT $ foldlM go delta new_tm_cs+  where+    go delta ct = MaybeT (addTmCt delta ct)++-----------------------+-- * Looking up VarInfo++emptyVarInfo :: Id -> VarInfo+emptyVarInfo x = VI (idType x) [] [] NoPM++lookupVarInfo :: TmState -> Id -> VarInfo+-- (lookupVarInfo tms x) tells what we know about 'x'+lookupVarInfo (TmSt env _) x = fromMaybe (emptyVarInfo x) (lookupSDIE env x)++initPossibleMatches :: TyState -> VarInfo -> DsM VarInfo+initPossibleMatches ty_st vi@VI{ vi_ty = ty, vi_cache = NoPM } = do+  -- New evidence might lead to refined info on ty, in turn leading to discovery+  -- of a COMPLETE set.+  res <- pmTopNormaliseType ty_st ty+  let ty' = normalisedSourceType res+  case splitTyConApp_maybe ty' of+    Nothing -> pure vi{ vi_ty = ty' }+    Just (tc, [_])+      | tc == tYPETyCon+      -- TYPE acts like an empty data type on the term-level (#14086), but+      -- it is a PrimTyCon, so tyConDataCons_maybe returns Nothing. Hence a+      -- special case.+      -> pure vi{ vi_ty = ty', vi_cache = PM (pure emptyUniqDSet) }+    Just (tc, tc_args) -> do+      -- See Note [COMPLETE sets on data families]+      (tc_rep, tc_fam) <- case tyConFamInst_maybe tc of+        Just (tc_fam, _) -> pure (tc, tc_fam)+        Nothing -> do+          env <- dsGetFamInstEnvs+          let (tc_rep, _tc_rep_args, _co) = tcLookupDataFamInst env tc tc_args+          pure (tc_rep, tc)+      -- Note that the common case here is tc_rep == tc_fam+      let mb_rdcs = map RealDataCon <$> tyConDataCons_maybe tc_rep+      let rdcs = maybeToList mb_rdcs+      -- NB: tc_fam, because COMPLETE sets are associated with the parent data+      -- family TyCon+      pragmas <- dsGetCompleteMatches tc_fam+      let fams = mapM dsLookupConLike . completeMatchConLikes+      pscs <- mapM fams pragmas+      -- pprTrace "initPossibleMatches" (ppr ty $$ ppr ty' $$ ppr tc_rep <+> ppr tc_fam <+> ppr tc_args $$ ppr (rdcs ++ pscs)) (return ())+      case NonEmpty.nonEmpty (rdcs ++ pscs) of+        Nothing -> pure vi{ vi_ty = ty' } -- Didn't find any COMPLETE sets+        Just cs -> pure vi{ vi_ty = ty', vi_cache = PM (mkUniqDSet <$> cs) }+initPossibleMatches _     vi                                   = pure vi++-- | @initLookupVarInfo ts x@ looks up the 'VarInfo' for @x@ in @ts@ and tries+-- to initialise the 'vi_cache' component if it was 'NoPM' through+-- 'initPossibleMatches'.+initLookupVarInfo :: Delta -> Id -> DsM VarInfo+initLookupVarInfo MkDelta{ delta_tm_st = ts, delta_ty_st = ty_st } x+  = initPossibleMatches ty_st (lookupVarInfo ts x)++{- Note [COMPLETE sets on data families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+User-defined COMPLETE sets involving data families are attached to the family+TyCon, whereas the built-in COMPLETE set is attached to a data family instance's+representation TyCon. This matters for COMPLETE sets involving both DataCons+and PatSyns (from #17207):++  data family T a+  data family instance T () = A | B+  pattern C = B+  {-# COMPLETE A, C #-}+  f :: T () -> ()+  f A = ()+  f C = ()++The match on A is actually wrapped in a CoPat, matching impedance between T ()+and its representation TyCon, which we translate as+@x | let y = x |> co, A <- y@ in PmCheck.++Which TyCon should we use for looking up the COMPLETE set? The representation+TyCon from the match on A would only reveal the built-in COMPLETE set, while the+data family TyCon would only give the user-defined one. But when initialising+the PossibleMatches for a given Type, we want to do so only once, because+merging different COMPLETE sets after the fact is very complicated and possibly+inefficient.++So in fact, we just *drop* the coercion arising from the CoPat when handling+handling the constraint @y ~ x |> co@ in addVarCoreCt, just equating @y ~ x@.+We then handle the fallout in initPossibleMatches, which has to get a hand at+both the representation TyCon tc_rep and the parent data family TyCon tc_fam.+It considers three cases after having established that the Type is a TyConApp:++1. The TyCon is a vanilla data type constructor+2. The TyCon is tc_rep+3. The TyCon is tc_fam++1. is simple and subsumed by the handling of the other two.+We check for case 2. by 'tyConFamInst_maybe' and get the tc_fam out.+Otherwise (3.), we try to lookup the data family instance at that particular+type to get out the tc_rep. In case 1., this will just return the original+TyCon, so tc_rep = tc_fam afterwards.+-}++------------------------------------------------+-- * Exported utility functions querying 'Delta'++-- | Check whether adding a constraint @x ~ BOT@ to 'Delta' succeeds.+canDiverge :: Delta -> Id -> Bool+canDiverge delta@MkDelta{ delta_tm_st = ts } x+  | VI _ pos neg _ <- lookupVarInfo ts x+  = null neg && all pos_can_diverge pos+  where+    pos_can_diverge (PmAltConLike (RealDataCon dc), [y])+      -- See Note [Divergence of Newtype matches]+      | isNewTyCon (dataConTyCon dc) = canDiverge delta y+    pos_can_diverge _ = False++{- Note [Divergence of Newtype matches]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Newtypes behave rather strangely when compared to ordinary DataCons. In a+pattern-match, they behave like a irrefutable (lazy) match, but for inhabitation+testing purposes (e.g. at construction sites), they behave rather like a DataCon+with a *strict* field, because they don't contribute their own bottom and are+inhabited iff the wrapped type is inhabited.++This distinction becomes apparent in #17248:++  newtype T2 a = T2 a+  g _      True = ()+  g (T2 _) True = ()+  g !_     True = ()++If we treat Newtypes like we treat regular DataCons, we would mark the third+clause as redundant, which clearly is unsound. The solution:+1. When checking the PmCon in 'pmCheck', never mark the result as Divergent if+   it's a Newtype match.+2. Regard @T2 x@ as 'canDiverge' iff @x@ 'canDiverge'. E.g. @T2 x ~ _|_@ <=>+   @x ~ _|_@. This way, the third clause will still be marked as inaccessible+   RHS instead of redundant.+3. When testing for inhabitants ('mkOneConFull'), we regard the newtype field as+   strict, so that the newtype is inhabited iff its field is inhabited.+-}++lookupRefuts :: Uniquable k => Delta -> k -> [PmAltCon]+-- Unfortunately we need the extra bit of polymorphism and the unfortunate+-- duplication of lookupVarInfo here.+lookupRefuts MkDelta{ delta_tm_st = ts@(TmSt (SDIE env) _) } k =+  case lookupUDFM env k of+    Nothing -> []+    Just (Indirect y) -> vi_neg (lookupVarInfo ts y)+    Just (Entry vi)   -> vi_neg vi++isDataConSolution :: (PmAltCon, [Id]) -> Bool+isDataConSolution (PmAltConLike (RealDataCon _), _) = True+isDataConSolution _                                 = False++-- @lookupSolution delta x@ picks a single solution ('vi_pos') of @x@ from+-- possibly many, preferring 'RealDataCon' solutions whenever possible.+lookupSolution :: Delta -> Id -> Maybe (PmAltCon, [Id])+lookupSolution delta x = case vi_pos (lookupVarInfo (delta_tm_st delta) x) of+  []                                         -> Nothing+  pos+    | Just sol <- find isDataConSolution pos -> Just sol+    | otherwise                              -> Just (head pos)++-------------------------------+-- * Adding facts to the oracle++-- | A term constraint. Either equates two variables or a variable with a+-- 'PmAltCon' application.+data TmCt+  = TmVarVar     !Id !Id+  | TmVarCon     !Id !PmAltCon ![Id]+  | TmVarNonVoid !Id++instance Outputable TmCt where+  ppr (TmVarVar x y)        = ppr x <+> char '~' <+> ppr y+  ppr (TmVarCon x con args) = ppr x <+> char '~' <+> hsep (ppr con : map ppr args)+  ppr (TmVarNonVoid x)      = ppr x <+> text "/~ ⊥"++-- | Add type equalities to 'Delta'.+addTypeEvidence :: Delta -> Bag EvVar -> DsM (Maybe Delta)+addTypeEvidence delta dicts+  = runSatisfiabilityCheck delta (tyIsSatisfiable True (TyCt . evVarPred <$> dicts))++-- | Tries to equate two representatives in 'Delta'.+-- See Note [TmState invariants].+addTmCt :: Delta -> TmCt -> DsM (Maybe Delta)+addTmCt delta ct = runMaybeT $ case ct of+  TmVarVar x y        -> addVarVarCt delta (x, y)+  TmVarCon x con args -> addVarConCt delta x con args+  TmVarNonVoid x      -> addVarNonVoidCt delta x++-- | Record that a particular 'Id' can't take the shape of a 'PmAltCon' in the+-- 'Delta' and return @Nothing@ if that leads to a contradiction.+-- See Note [TmState invariants].+addRefutableAltCon :: Delta -> Id -> PmAltCon -> DsM (Maybe Delta)+addRefutableAltCon delta@MkDelta{ delta_tm_st = TmSt env reps } x nalt = runMaybeT $ do+  vi@(VI _ pos neg pm) <- lift (initLookupVarInfo delta x)+  -- 1. Bail out quickly when nalt contradicts a solution+  let contradicts nalt (cl, _args) = eqPmAltCon cl nalt == Equal+  guard (not (any (contradicts nalt) pos))+  -- 2. Only record the new fact when it's not already implied by one of the+  -- solutions+  let implies nalt (cl, _args) = eqPmAltCon cl nalt == Disjoint+  let neg'+        | any (implies nalt) pos = neg+        -- See Note [Completeness checking with required Thetas]+        | hasRequiredTheta nalt  = neg+        | otherwise              = unionLists neg [nalt]+  let vi_ext = vi{ vi_neg = neg' }+  -- 3. Make sure there's at least one other possible constructor+  vi' <- case nalt of+    PmAltConLike cl+      -> MaybeT (ensureInhabited delta vi_ext{ vi_cache = markMatched cl pm })+    _ -> pure vi_ext+  pure delta{ delta_tm_st = TmSt (setEntrySDIE env x vi') reps }++hasRequiredTheta :: PmAltCon -> Bool+hasRequiredTheta (PmAltConLike cl) = notNull req_theta+  where+    (_,_,_,_,req_theta,_,_) = conLikeFullSig cl+hasRequiredTheta _                 = False++{- Note [Completeness checking with required Thetas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the situation in #11224++    import Text.Read (readMaybe)+    pattern PRead :: Read a => () => a -> String+    pattern PRead x <- (readMaybe -> Just x)+    f :: String -> Int+    f (PRead x)  = x+    f (PRead xs) = length xs+    f _          = 0++Is the first match exhaustive on the PRead synonym? Should the second line thus+deemed redundant? The answer is, of course, No! The required theta is like a+hidden parameter which must be supplied at the pattern match site, so PRead+is much more like a view pattern (where behavior depends on the particular value+passed in).+The simple solution here is to forget in 'addRefutableAltCon' that we matched+on synonyms with a required Theta like @PRead@, so that subsequent matches on+the same constructor are never flagged as redundant. The consequence is that+we no longer detect the actually redundant match in++    g :: String -> Int+    g (PRead x) = x+    g (PRead y) = y -- redundant!+    g _         = 0++But that's a small price to pay, compared to the proper solution here involving+storing required arguments along with the PmAltConLike in 'vi_neg'.+-}++-- | Guess the universal argument types of a ConLike from an instantiation of+-- its result type. Rather easy for DataCons, but not so much for PatSynCons.+-- See Note [Pattern synonym result type] in PatSyn.hs.+guessConLikeUnivTyArgsFromResTy :: FamInstEnvs -> Type -> ConLike -> Maybe [Type]+guessConLikeUnivTyArgsFromResTy env res_ty (RealDataCon _) = do+  (tc, tc_args) <- splitTyConApp_maybe res_ty+  -- Consider data families: In case of a DataCon, we need to translate to+  -- the representation TyCon. For PatSyns, they are relative to the data+  -- family TyCon, so we don't need to translate them.+  let (_, tc_args', _) = tcLookupDataFamInst env tc tc_args+  Just tc_args'+guessConLikeUnivTyArgsFromResTy _   res_ty (PatSynCon ps)  = do+  -- We are successful if we managed to instantiate *every* univ_tv of con.+  -- This is difficult and bound to fail in some cases, see+  -- Note [Pattern synonym result type] in PatSyn.hs. So we just try our best+  -- here and be sure to return an instantiation when we can substitute every+  -- universally quantified type variable.+  -- We *could* instantiate all the other univ_tvs just to fresh variables, I+  -- suppose, but that means we get weird field types for which we don't know+  -- anything. So we prefer to keep it simple here.+  let (univ_tvs,_,_,_,_,con_res_ty) = patSynSig ps+  subst <- tcMatchTy con_res_ty res_ty+  traverse (lookupTyVar subst) univ_tvs++-- | Kind of tries to add a non-void contraint to 'Delta', but doesn't really+-- commit to upholding that constraint in the future. This will be rectified+-- in a follow-up patch. The status quo should work good enough for now.+addVarNonVoidCt :: Delta -> Id -> MaybeT DsM Delta+addVarNonVoidCt delta@MkDelta{ delta_tm_st = TmSt env reps } x = do+  vi  <- lift $ initLookupVarInfo delta x+  vi' <- MaybeT $ ensureInhabited delta vi+  -- vi' has probably constructed and then thinned out some PossibleMatches.+  -- We want to cache that work+  pure delta{ delta_tm_st = TmSt (setEntrySDIE env x vi') reps}++ensureInhabited :: Delta -> VarInfo -> DsM (Maybe VarInfo)+   -- Returns (Just vi) if at least one member of each ConLike in the COMPLETE+   -- set satisfies the oracle+   --+   -- Internally uses and updates the ConLikeSets in vi_cache.+   --+   -- NB: Does /not/ filter each ConLikeSet with the oracle; members may+   --     remain that do not statisfy it.  This lazy approach just+   --     avoids doing unnecessary work.+ensureInhabited delta vi = fmap (set_cache vi) <$> test (vi_cache vi) -- This would be much less tedious with lenses+  where+    set_cache vi cache = vi { vi_cache = cache }++    test NoPM    = pure (Just NoPM)+    test (PM ms) = runMaybeT (PM <$> traverse one_set ms)++    one_set cs = find_one_inh cs (uniqDSetToList cs)++    find_one_inh :: ConLikeSet -> [ConLike] -> MaybeT DsM ConLikeSet+    -- (find_one_inh cs cls) iterates over cls, deleting from cs+    -- any uninhabited elements of cls.  Stop (returning Just cs)+    -- when you see an inhabited element; return Nothing if all+    -- are uninhabited+    find_one_inh _  [] = mzero+    find_one_inh cs (con:cons) = lift (inh_test con) >>= \case+      True  -> pure cs+      False -> find_one_inh (delOneFromUniqDSet cs con) cons++    inh_test :: ConLike -> DsM Bool+    -- @inh_test K@ Returns False if a non-bottom value @v::ty@ cannot possibly+    -- be of form @K _ _ _@. Returning True is always sound.+    --+    -- It's like 'DataCon.dataConCannotMatch', but more clever because it takes+    -- the facts in Delta into account.+    inh_test con = do+      env <- dsGetFamInstEnvs+      case guessConLikeUnivTyArgsFromResTy env (vi_ty vi) con of+        Nothing -> pure True -- be conservative about this+        Just arg_tys -> do+          (_vars, ty_cs, strict_arg_tys) <- mkOneConFull arg_tys con+          tracePm "inh_test" (ppr con $$ ppr ty_cs)+          -- No need to run the term oracle compared to pmIsSatisfiable+          fmap isJust <$> runSatisfiabilityCheck delta $ mconcat+            -- Important to pass False to tyIsSatisfiable here, so that we won't+            -- recursively call ensureAllPossibleMatchesInhabited, leading to an+            -- endless recursion.+            [ tyIsSatisfiable False ty_cs+            , tysAreNonVoid initRecTc strict_arg_tys+            ]++-- | Checks if every 'VarInfo' in the term oracle has still an inhabited+-- 'vi_cache', considering the current type information in 'Delta'.+-- This check is necessary after having matched on a GADT con to weed out+-- impossible matches.+ensureAllPossibleMatchesInhabited :: Delta -> DsM (Maybe Delta)+ensureAllPossibleMatchesInhabited delta@MkDelta{ delta_tm_st = TmSt env reps }+  = runMaybeT (set_tm_cs_env delta <$> traverseSDIE go env)+  where+    set_tm_cs_env delta env = delta{ delta_tm_st = TmSt env reps }+    go vi = MaybeT (ensureInhabited delta vi)++--------------------------------------+-- * Term oracle unification procedure++-- | Try to unify two 'Id's and record the gained knowledge in 'Delta'.+--+-- Returns @Nothing@ when there's a contradiction. Returns @Just delta@+-- when the constraint was compatible with prior facts, in which case @delta@+-- has integrated the knowledge from the equality constraint.+--+-- See Note [TmState invariants].+addVarVarCt :: Delta -> (Id, Id) -> MaybeT DsM Delta+addVarVarCt delta@MkDelta{ delta_tm_st = TmSt env _ } (x, y)+  -- It's important that we never @equate@ two variables of the same equivalence+  -- class, otherwise we might get cyclic substitutions.+  -- Cf. 'extendSubstAndSolve' and+  -- @testsuite/tests/pmcheck/should_compile/CyclicSubst.hs@.+  | sameRepresentativeSDIE env x y = pure delta+  | otherwise                      = equate delta x y++-- | @equate ts@(TmSt env) x y@ merges the equivalence classes of @x@ and @y@ by+-- adding an indirection to the environment.+-- Makes sure that the positive and negative facts of @x@ and @y@ are+-- compatible.+-- Preconditions: @not (sameRepresentativeSDIE env x y)@+--+-- See Note [TmState invariants].+equate :: Delta -> Id -> Id -> MaybeT DsM Delta+equate delta@MkDelta{ delta_tm_st = TmSt env reps } x y+  = ASSERT( not (sameRepresentativeSDIE env x y) )+    case (lookupSDIE env x, lookupSDIE env y) of+      (Nothing, _) -> pure (delta{ delta_tm_st = TmSt (setIndirectSDIE env x y) reps })+      (_, Nothing) -> pure (delta{ delta_tm_st = TmSt (setIndirectSDIE env y x) reps })+      -- Merge the info we have for x into the info for y+      (Just vi_x, Just vi_y) -> do+        -- This assert will probably trigger at some point...+        -- We should decide how to break the tie+        MASSERT2( vi_ty vi_x `eqType` vi_ty vi_y, text "Not same type" )+        -- First assume that x and y are in the same equivalence class+        let env_ind = setIndirectSDIE env x y+        -- Then sum up the refinement counters+        let env_refs = setEntrySDIE env_ind y vi_y+        let delta_refs = delta{ delta_tm_st = TmSt env_refs reps }+        -- and then gradually merge every positive fact we have on x into y+        let add_fact delta (cl, args) = addVarConCt delta y cl args+        delta_pos <- foldlM add_fact delta_refs (vi_pos vi_x)+        -- Do the same for negative info+        let add_refut delta nalt = MaybeT (addRefutableAltCon delta y nalt)+        delta_neg <- foldlM add_refut delta_pos (vi_neg vi_x)+        -- vi_cache will be updated in addRefutableAltCon, so we are good to+        -- go!+        pure delta_neg++-- | @addVarConCt x alt args ts@ extends the substitution with a solution+-- @x :-> (alt, args)@ if compatible with refutable shapes of @x@ and its+-- other solutions, reject (@Nothing@) otherwise.+--+-- See Note [TmState invariants].+addVarConCt :: Delta -> Id -> PmAltCon -> [Id] -> MaybeT DsM Delta+addVarConCt delta@MkDelta{ delta_tm_st = TmSt env reps } x alt args = do+  VI ty pos neg cache <- lift (initLookupVarInfo delta x)+  -- First try to refute with a negative fact+  guard (all ((/= Equal) . eqPmAltCon alt) neg)+  -- Then see if any of the other solutions (remember: each of them is an+  -- additional refinement of the possible values x could take) indicate a+  -- contradiction+  guard (all ((/= Disjoint) . eqPmAltCon alt . fst) pos)+  -- Now we should be good! Add (alt, args) as a possible solution, or refine an+  -- existing one+  case find ((== Equal) . eqPmAltCon alt . fst) pos of+    Just (_, other_args) -> do+      foldlM addVarVarCt delta (zip args other_args)+    Nothing -> do+      -- Filter out redundant negative facts (those that compare Just False to+      -- the new solution)+      let neg' = filter ((== PossiblyOverlap) . eqPmAltCon alt) neg+      let pos' = (alt,args):pos+      pure delta{ delta_tm_st = TmSt (setEntrySDIE env x (VI ty pos' neg' cache)) reps}++----------------------------------------+-- * Enumerating inhabitation candidates++-- | Information about a conlike that is relevant to coverage checking.+-- It is called an \"inhabitation candidate\" since it is a value which may+-- possibly inhabit some type, but only if its term constraints ('ic_tm_cs')+-- and type constraints ('ic_ty_cs') are permitting, and if all of its strict+-- argument types ('ic_strict_arg_tys') are inhabitable.+-- See @Note [Strict argument type constraints]@.+data InhabitationCandidate =+  InhabitationCandidate+  { ic_tm_cs          :: Bag TmCt+  , ic_ty_cs          :: Bag TyCt+  , ic_strict_arg_tys :: [Type]+  }++instance Outputable InhabitationCandidate where+  ppr (InhabitationCandidate tm_cs ty_cs strict_arg_tys) =+    text "InhabitationCandidate" <+>+      vcat [ text "ic_tm_cs          =" <+> ppr tm_cs+           , text "ic_ty_cs          =" <+> ppr ty_cs+           , text "ic_strict_arg_tys =" <+> ppr strict_arg_tys ]++mkInhabitationCandidate :: Id -> DataCon -> DsM InhabitationCandidate+-- Precondition: idType x is a TyConApp, so that tyConAppArgs in here is safe.+mkInhabitationCandidate x dc = do+  let cl = RealDataCon dc+  let tc_args = tyConAppArgs (idType x)+  (arg_vars, ty_cs, strict_arg_tys) <- mkOneConFull tc_args cl+  pure InhabitationCandidate+        { ic_tm_cs = unitBag (TmVarCon x (PmAltConLike cl) arg_vars)+        , ic_ty_cs = ty_cs+        , ic_strict_arg_tys = strict_arg_tys+        }++-- | Generate all 'InhabitationCandidate's for a given type. The result is+-- either @'Left' ty@, if the type cannot be reduced to a closed algebraic type+-- (or if it's one trivially inhabited, like 'Int'), or @'Right' candidates@,+-- if it can. In this case, the candidates are the signature of the tycon, each+-- one accompanied by the term- and type- constraints it gives rise to.+-- See also Note [Checking EmptyCase Expressions]+inhabitationCandidates :: Delta -> Type+                       -> DsM (Either Type (TyCon, Id, [InhabitationCandidate]))+inhabitationCandidates MkDelta{ delta_ty_st = ty_st } ty = do+  pmTopNormaliseType ty_st ty >>= \case+    NoChange _                    -> alts_to_check ty     ty      []+    NormalisedByConstraints ty'   -> alts_to_check ty'    ty'     []+    HadRedexes src_ty dcs core_ty -> alts_to_check src_ty core_ty dcs+  where+    build_newtype :: (Type, DataCon, Type) -> Id -> DsM (Id, TmCt)+    build_newtype (ty, dc, _arg_ty) x = do+      -- ty is the type of @dc x@. It's a @dataConTyCon dc@ application.+      y <- mkPmId ty+      pure (y, TmVarCon y (PmAltConLike (RealDataCon dc)) [x])++    build_newtypes :: Id -> [(Type, DataCon, Type)] -> DsM (Id, [TmCt])+    build_newtypes x = foldrM (\dc (x, cts) -> go dc x cts) (x, [])+      where+        go dc x cts = second (:cts) <$> build_newtype dc x++    -- Inhabitation candidates, using the result of pmTopNormaliseType+    alts_to_check :: Type -> Type -> [(Type, DataCon, Type)]+                  -> DsM (Either Type (TyCon, Id, [InhabitationCandidate]))+    alts_to_check src_ty core_ty dcs = case splitTyConApp_maybe core_ty of+      Just (tc, _)+        |  isTyConTriviallyInhabited tc+        -> case dcs of+             []    -> return (Left src_ty)+             (_:_) -> do inner <- mkPmId core_ty+                         (outer, new_tm_cts) <- build_newtypes inner dcs+                         return $ Right (tc, outer, [InhabitationCandidate+                           { ic_tm_cs = listToBag new_tm_cts+                           , ic_ty_cs = emptyBag, ic_strict_arg_tys = [] }])++        |  pmIsClosedType core_ty && not (isAbstractTyCon tc)+           -- Don't consider abstract tycons since we don't know what their+           -- constructors are, which makes the results of coverage checking+           -- them extremely misleading.+        -> do+             inner <- mkPmId core_ty -- it would be wrong to unify inner+             alts <- mapM (mkInhabitationCandidate inner) (tyConDataCons tc)+             (outer, new_tm_cts) <- build_newtypes inner dcs+             let wrap_dcs alt = alt{ ic_tm_cs = listToBag new_tm_cts `unionBags` ic_tm_cs alt}+             return $ Right (tc, outer, map wrap_dcs alts)+      -- For other types conservatively assume that they are inhabited.+      _other -> return (Left src_ty)++-- | All these types are trivially inhabited+triviallyInhabitedTyCons :: UniqSet TyCon+triviallyInhabitedTyCons = mkUniqSet [+    charTyCon, doubleTyCon, floatTyCon, intTyCon, wordTyCon, word8TyCon+  ]++isTyConTriviallyInhabited :: TyCon -> Bool+isTyConTriviallyInhabited tc = elementOfUniqSet tc triviallyInhabitedTyCons++----------------------------+-- * Detecting vacuous types++{- Note [Checking EmptyCase Expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Empty case expressions are strict on the scrutinee. That is, `case x of {}`+will force argument `x`. Hence, `checkMatches` is not sufficient for checking+empty cases, because it assumes that the match is not strict (which is true+for all other cases, apart from EmptyCase). This gave rise to #10746. Instead,+we do the following:++1. We normalise the outermost type family redex, data family redex or newtype,+   using pmTopNormaliseType (in types/FamInstEnv.hs). This computes 3+   things:+   (a) A normalised type src_ty, which is equal to the type of the scrutinee in+       source Haskell (does not normalise newtypes or data families)+   (b) The actual normalised type core_ty, which coincides with the result+       topNormaliseType_maybe. This type is not necessarily equal to the input+       type in source Haskell. And this is precicely the reason we compute (a)+       and (c): the reasoning happens with the underlying types, but both the+       patterns and types we print should respect newtypes and also show the+       family type constructors and not the representation constructors.++   (c) A list of all newtype data constructors dcs, each one corresponding to a+       newtype rewrite performed in (b).++   For an example see also Note [Type normalisation]+   in types/FamInstEnv.hs.++2. Function Check.checkEmptyCase' performs the check:+   - If core_ty is not an algebraic type, then we cannot check for+     inhabitation, so we emit (_ :: src_ty) as missing, conservatively assuming+     that the type is inhabited.+   - If core_ty is an algebraic type, then we unfold the scrutinee to all+     possible constructor patterns, using inhabitationCandidates, and then+     check each one for constraint satisfiability, same as we do for normal+     pattern match checking.+-}++-- | A 'SatisfiabilityCheck' based on "NonVoid ty" constraints, e.g. Will+-- check if the @strict_arg_tys@ are actually all inhabited.+-- Returns the old 'Delta' if all the types are non-void according to 'Delta'.+tysAreNonVoid :: RecTcChecker -> [Type] -> SatisfiabilityCheck+tysAreNonVoid rec_env strict_arg_tys = SC $ \delta -> do+  all_non_void <- checkAllNonVoid rec_env delta strict_arg_tys+  -- Check if each strict argument type is inhabitable+  pure $ if all_non_void+            then Just delta+            else Nothing++-- | Implements two performance optimizations, as described in+-- @Note [Strict argument type constraints]@.+checkAllNonVoid :: RecTcChecker -> Delta -> [Type] -> DsM Bool+checkAllNonVoid rec_ts amb_cs strict_arg_tys = do+  let definitely_inhabited = definitelyInhabitedType (delta_ty_st amb_cs)+  tys_to_check <- filterOutM definitely_inhabited strict_arg_tys+  let rec_max_bound | tys_to_check `lengthExceeds` 1+                    = 1+                    | otherwise+                    = defaultRecTcMaxBound+      rec_ts' = setRecTcMaxBound rec_max_bound rec_ts+  allM (nonVoid rec_ts' amb_cs) tys_to_check++-- | Checks if a strict argument type of a conlike is inhabitable by a+-- terminating value (i.e, an 'InhabitationCandidate').+-- See @Note [Strict argument type constraints]@.+nonVoid+  :: RecTcChecker -- ^ The per-'TyCon' recursion depth limit.+  -> Delta        -- ^ The ambient term/type constraints (known to be+                  --   satisfiable).+  -> Type         -- ^ The strict argument type.+  -> DsM Bool     -- ^ 'True' if the strict argument type might be inhabited by+                  --   a terminating value (i.e., an 'InhabitationCandidate').+                  --   'False' if it is definitely uninhabitable by anything+                  --   (except bottom).+nonVoid rec_ts amb_cs strict_arg_ty = do+  mb_cands <- inhabitationCandidates amb_cs strict_arg_ty+  case mb_cands of+    Right (tc, _, cands)+      |  Just rec_ts' <- checkRecTc rec_ts tc+      -> anyM (cand_is_inhabitable rec_ts' amb_cs) cands+           -- A strict argument type is inhabitable by a terminating value if+           -- at least one InhabitationCandidate is inhabitable.+    _ -> pure True+           -- Either the type is trivially inhabited or we have exceeded the+           -- recursion depth for some TyCon (so bail out and conservatively+           -- claim the type is inhabited).+  where+    -- Checks if an InhabitationCandidate for a strict argument type:+    --+    -- (1) Has satisfiable term and type constraints.+    -- (2) Has 'nonVoid' strict argument types (we bail out of this+    --     check if recursion is detected).+    --+    -- See Note [Strict argument type constraints]+    cand_is_inhabitable :: RecTcChecker -> Delta+                        -> InhabitationCandidate -> DsM Bool+    cand_is_inhabitable rec_ts amb_cs+      (InhabitationCandidate{ ic_tm_cs          = new_tm_cs+                            , ic_ty_cs          = new_ty_cs+                            , ic_strict_arg_tys = new_strict_arg_tys }) =+        fmap isJust $ runSatisfiabilityCheck amb_cs $ mconcat+          [ tyIsSatisfiable False new_ty_cs+          , tmIsSatisfiable new_tm_cs+          , tysAreNonVoid rec_ts new_strict_arg_tys+          ]++-- | @'definitelyInhabitedType' ty@ returns 'True' if @ty@ has at least one+-- constructor @C@ such that:+--+-- 1. @C@ has no equality constraints.+-- 2. @C@ has no strict argument types.+--+-- See the @Note [Strict argument type constraints]@.+definitelyInhabitedType :: TyState -> Type -> DsM Bool+definitelyInhabitedType ty_st ty = do+  res <- pmTopNormaliseType ty_st ty+  pure $ case res of+           HadRedexes _ cons _ -> any meets_criteria cons+           _                   -> False+  where+    meets_criteria :: (Type, DataCon, Type) -> Bool+    meets_criteria (_, con, _) =+      null (dataConEqSpec con) && -- (1)+      null (dataConImplBangs con) -- (2)++{- Note [Strict argument type constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the ConVar case of clause processing, each conlike K traditionally+generates two different forms of constraints:++* A term constraint (e.g., x ~ K y1 ... yn)+* Type constraints from the conlike's context (e.g., if K has type+  forall bs. Q => s1 .. sn -> T tys, then Q would be its type constraints)++As it turns out, these alone are not enough to detect a certain class of+unreachable code. Consider the following example (adapted from #15305):++  data K = K1 | K2 !Void++  f :: K -> ()+  f K1 = ()++Even though `f` doesn't match on `K2`, `f` is exhaustive in its patterns. Why?+Because it's impossible to construct a terminating value of type `K` using the+`K2` constructor, and thus it's impossible for `f` to ever successfully match+on `K2`.++The reason is because `K2`'s field of type `Void` is //strict//. Because there+are no terminating values of type `Void`, any attempt to construct something+using `K2` will immediately loop infinitely or throw an exception due to the+strictness annotation. (If the field were not strict, then `f` could match on,+say, `K2 undefined` or `K2 (let x = x in x)`.)++Since neither the term nor type constraints mentioned above take strict+argument types into account, we make use of the `nonVoid` function to+determine whether a strict type is inhabitable by a terminating value or not.++`nonVoid ty` returns True when either:+1. `ty` has at least one InhabitationCandidate for which both its term and type+   constraints are satifiable, and `nonVoid` returns `True` for all of the+   strict argument types in that InhabitationCandidate.+2. We're unsure if it's inhabited by a terminating value.++`nonVoid ty` returns False when `ty` is definitely uninhabited by anything+(except bottom). Some examples:++* `nonVoid Void` returns False, since Void has no InhabitationCandidates.+  (This is what lets us discard the `K2` constructor in the earlier example.)+* `nonVoid (Int :~: Int)` returns True, since it has an InhabitationCandidate+  (through the Refl constructor), and its term constraint (x ~ Refl) and+  type constraint (Int ~ Int) are satisfiable.+* `nonVoid (Int :~: Bool)` returns False. Although it has an+  InhabitationCandidate (by way of Refl), its type constraint (Int ~ Bool) is+  not satisfiable.+* Given the following definition of `MyVoid`:++    data MyVoid = MkMyVoid !Void++  `nonVoid MyVoid` returns False. The InhabitationCandidate for the MkMyVoid+  constructor contains Void as a strict argument type, and since `nonVoid Void`+  returns False, that InhabitationCandidate is discarded, leaving no others.++* Performance considerations++We must be careful when recursively calling `nonVoid` on the strict argument+types of an InhabitationCandidate, because doing so naïvely can cause GHC to+fall into an infinite loop. Consider the following example:++  data Abyss = MkAbyss !Abyss++  stareIntoTheAbyss :: Abyss -> a+  stareIntoTheAbyss x = case x of {}++In principle, stareIntoTheAbyss is exhaustive, since there is no way to+construct a terminating value using MkAbyss. However, both the term and type+constraints for MkAbyss are satisfiable, so the only way one could determine+that MkAbyss is unreachable is to check if `nonVoid Abyss` returns False.+There is only one InhabitationCandidate for Abyss—MkAbyss—and both its term+and type constraints are satisfiable, so we'd need to check if `nonVoid Abyss`+returns False... and now we've entered an infinite loop!++To avoid this sort of conundrum, `nonVoid` uses a simple test to detect the+presence of recursive types (through `checkRecTc`), and if recursion is+detected, we bail out and conservatively assume that the type is inhabited by+some terminating value. This avoids infinite loops at the expense of making+the coverage checker incomplete with respect to functions like+stareIntoTheAbyss above. Then again, the same problem occurs with recursive+newtypes, like in the following code:++  newtype Chasm = MkChasm Chasm++  gazeIntoTheChasm :: Chasm -> a+  gazeIntoTheChasm x = case x of {} -- Erroneously warned as non-exhaustive++So this limitation is somewhat understandable.++Note that even with this recursion detection, there is still a possibility that+`nonVoid` can run in exponential time. Consider the following data type:++  data T = MkT !T !T !T++If we call `nonVoid` on each of its fields, that will require us to once again+check if `MkT` is inhabitable in each of those three fields, which in turn will+require us to check if `MkT` is inhabitable again... As you can see, the+branching factor adds up quickly, and if the recursion depth limit is, say,+100, then `nonVoid T` will effectively take forever.++To mitigate this, we check the branching factor every time we are about to call+`nonVoid` on a list of strict argument types. If the branching factor exceeds 1+(i.e., if there is potential for exponential runtime), then we limit the+maximum recursion depth to 1 to mitigate the problem. If the branching factor+is exactly 1 (i.e., we have a linear chain instead of a tree), then it's okay+to stick with a larger maximum recursion depth.++Another microoptimization applies to data types like this one:++  data S a = ![a] !T++Even though there is a strict field of type [a], it's quite silly to call+nonVoid on it, since it's "obvious" that it is inhabitable. To make this+intuition formal, we say that a type is definitely inhabitable (DI) if:++  * It has at least one constructor C such that:+    1. C has no equality constraints (since they might be unsatisfiable)+    2. C has no strict argument types (since they might be uninhabitable)++It's relatively cheap to check if a type is DI, so before we call `nonVoid`+on a list of strict argument types, we filter out all of the DI ones.+-}++--------------------------------------------+-- * Providing positive evidence for a Delta++-- | @provideEvidence vs n delta@ returns a list of+-- at most @n@ (but perhaps empty) refinements of @delta@ that instantiate+-- @vs@ to compatible constructor applications or wildcards.+-- Negative information is only retained if literals are involved or when+-- for recursive GADTs.+provideEvidence :: [Id] -> Int -> Delta -> DsM [Delta]+provideEvidence = go+  where+    go _      0 _     = pure []+    go []     _ delta = pure [delta]+    go (x:xs) n delta = do+      tracePm "provideEvidence" (ppr x $$ ppr xs $$ ppr delta $$ ppr n)+      VI _ pos neg _ <- initLookupVarInfo delta x+      case pos of+        _:_ -> do+          -- All solutions must be valid at once. Try to find candidates for their+          -- fields. Example:+          --   f x@(Just _) True = case x of SomePatSyn _ -> ()+          -- after this clause, we want to report that+          --   * @f Nothing _@ is uncovered+          --   * @f x False@ is uncovered+          -- where @x@ will have two possibly compatible solutions, @Just y@ for+          -- some @y@ and @SomePatSyn z@ for some @z@. We must find evidence for @y@+          -- and @z@ that is valid at the same time. These constitute arg_vas below.+          let arg_vas = concatMap (\(_cl, args) -> args) pos+          go (arg_vas ++ xs) n delta+        []+          -- When there are literals involved, just print negative info+          -- instead of listing missed constructors+          | notNull [ l | PmAltLit l <- neg ]+          -> go xs n delta+        [] -> try_instantiate x xs n delta++    -- | Tries to instantiate a variable by possibly following the chain of+    -- newtypes and then instantiating to all ConLikes of the wrapped type's+    -- minimal residual COMPLETE set.+    try_instantiate :: Id -> [Id] -> Int -> Delta -> DsM [Delta]+    -- Convention: x binds the outer constructor in the chain, y the inner one.+    try_instantiate x xs n delta = do+      (_src_ty, dcs, core_ty) <- tntrGuts <$> pmTopNormaliseType (delta_ty_st delta) (idType x)+      let build_newtype (x, delta) (_ty, dc, arg_ty) = do+            y <- lift $ mkPmId arg_ty+            delta' <- addVarConCt delta x (PmAltConLike (RealDataCon dc)) [y]+            pure (y, delta')+      runMaybeT (foldlM build_newtype (x, delta) dcs) >>= \case+        Nothing -> pure []+        Just (y, newty_delta) -> do+          -- Pick a COMPLETE set and instantiate it (n at max). Take care of ⊥.+          pm     <- vi_cache <$> initLookupVarInfo newty_delta y+          mb_cls <- pickMinimalCompleteSet newty_delta pm+          case uniqDSetToList <$> mb_cls of+            Just cls@(_:_) -> instantiate_cons y core_ty xs n newty_delta cls+            Just [] | not (canDiverge newty_delta y) -> pure []+            -- Either ⊥ is still possible (think Void) or there are no COMPLETE+            -- sets available, so we can assume it's inhabited+            _ -> go xs n newty_delta++    instantiate_cons :: Id -> Type -> [Id] -> Int -> Delta -> [ConLike] -> DsM [Delta]+    instantiate_cons _ _  _  _ _     []       = pure []+    instantiate_cons _ _  _  0 _     _        = pure []+    instantiate_cons _ ty xs n delta _+      -- We don't want to expose users to GHC-specific constructors for Int etc.+      | fmap (isTyConTriviallyInhabited . fst) (splitTyConApp_maybe ty) == Just True+      = go xs n delta+    instantiate_cons x ty xs n delta (cl:cls) = do+      env <- dsGetFamInstEnvs+      case guessConLikeUnivTyArgsFromResTy env ty cl of+        Nothing -> pure [delta] -- No idea idea how to refine this one, so just finish off with a wildcard+        Just arg_tys -> do+          (arg_vars, new_ty_cs, strict_arg_tys) <- mkOneConFull arg_tys cl+          let new_tm_cs = unitBag (TmVarCon x (PmAltConLike cl) arg_vars)+          -- Now check satifiability+          mb_delta <- pmIsSatisfiable delta new_tm_cs new_ty_cs strict_arg_tys+          tracePm "instantiate_cons" (vcat [ ppr x+                                           , ppr (idType x)+                                           , ppr ty+                                           , ppr cl+                                           , ppr arg_tys+                                           , ppr new_tm_cs+                                           , ppr new_ty_cs+                                           , ppr strict_arg_tys+                                           , ppr delta+                                           , ppr mb_delta+                                           , ppr n ])+          con_deltas <- case mb_delta of+            Nothing     -> pure []+            -- NB: We don't prepend arg_vars as we don't have any evidence on+            -- them and we only want to split once on a data type. They are+            -- inhabited, otherwise pmIsSatisfiable would have refuted.+            Just delta' -> go xs n delta'+          other_cons_deltas <- instantiate_cons x ty xs (n - length con_deltas) delta cls+          pure (con_deltas ++ other_cons_deltas)++pickMinimalCompleteSet :: Delta -> PossibleMatches -> DsM (Maybe ConLikeSet)+pickMinimalCompleteSet _ NoPM      = pure Nothing+-- TODO: First prune sets with type info in delta. But this is good enough for+-- now and less costly. See #17386.+pickMinimalCompleteSet _ (PM clss) = do+  tracePm "pickMinimalCompleteSet" (ppr $ NonEmpty.toList clss)+  pure (Just (minimumBy (comparing sizeUniqDSet) clss))++-- | See if we already encountered a semantically equivalent expression and+-- return its representative.+representCoreExpr :: Delta -> CoreExpr -> DsM (Delta, Id)+representCoreExpr delta@MkDelta{ delta_tm_st = ts@TmSt{ ts_reps = reps } } e = do+  dflags <- getDynFlags+  let e' = simpleOptExpr dflags e+  case lookupCoreMap reps e' of+    Just rep -> pure (delta, rep)+    Nothing  -> do+      rep <- mkPmId (exprType e')+      let reps'  = extendCoreMap reps e' rep+      let delta' = delta{ delta_tm_st = ts{ ts_reps = reps' } }+      pure (delta', rep)++-- Most of our actions thread around a delta from one computation to the next,+-- thereby potentially failing. This is expressed in the following Monad:+-- type PmM a = StateT Delta (MaybeT DsM) a++-- | Records that a variable @x@ is equal to a 'CoreExpr' @e@.+addVarCoreCt :: Delta -> Id -> CoreExpr -> DsM (Maybe Delta)+addVarCoreCt delta x e = runMaybeT (execStateT (core_expr x e) delta)+  where+    -- | Takes apart a 'CoreExpr' and tries to extract as much information about+    -- literals and constructor applications as possible.+    core_expr :: Id -> CoreExpr -> StateT Delta (MaybeT DsM) ()+    -- TODO: Handle newtypes properly, by wrapping the expression in a DataCon+    -- This is the right thing for casts involving data family instances and+    -- their representation TyCon, though (which are not visible in source+    -- syntax). See Note [COMPLETE sets on data families]+    -- core_expr x e | pprTrace "core_expr" (ppr x $$ ppr e) False = undefined+    core_expr x (Cast e _co) = core_expr x e+    core_expr x (Tick _t e) = core_expr x e+    core_expr x e+      | Just (pmLitAsStringLit -> Just s) <- coreExprAsPmLit e+      , expr_ty `eqType` stringTy+      -- See Note [Representation of Strings in TmState]+      = case unpackFS s of+          -- We need this special case to break a loop with coreExprAsPmLit+          -- Otherwise we alternate endlessly between [] and ""+          [] -> data_con_app x nilDataCon []+          s' -> core_expr x (mkListExpr charTy (map mkCharExpr s'))+      | Just lit <- coreExprAsPmLit e+      = pm_lit x lit+      | Just (_in_scope, _empty_floats@[], dc, _arg_tys, args)+            <- exprIsConApp_maybe in_scope_env e+      = do { arg_ids <- traverse bind_expr args+           ; data_con_app x dc arg_ids }+      -- See Note [Detecting pattern synonym applications in expressions]+      | Var y <- e, Nothing <- isDataConId_maybe x+      -- We don't consider DataCons flexible variables+      = modifyT (\delta -> addVarVarCt delta (x, y))+      | otherwise+      -- Any other expression. Try to find other uses of a semantically+      -- equivalent expression and represent them by the same variable!+      = do { rep <- represent_expr e+           ; modifyT (\delta -> addVarVarCt delta (x, rep)) }+      where+        expr_ty       = exprType e+        expr_in_scope = mkInScopeSet (exprFreeVars e)+        in_scope_env  = (expr_in_scope, const NoUnfolding)+        -- It's inconvenient to get hold of a global in-scope set+        -- here, but it'll only be needed if exprIsConApp_maybe ends+        -- up substituting inside a forall or lambda (i.e. seldom)+        -- so using exprFreeVars seems fine.   See MR !1647.++        bind_expr :: CoreExpr -> StateT Delta (MaybeT DsM) Id+        bind_expr e = do+          x <- lift (lift (mkPmId (exprType e)))+          core_expr x e+          pure x++        -- See if we already encountered a semantically equivalent expression+        -- and return its representative+        represent_expr :: CoreExpr -> StateT Delta (MaybeT DsM) Id+        represent_expr e = StateT $ \delta ->+          swap <$> lift (representCoreExpr delta e)++    data_con_app :: Id -> DataCon -> [Id] -> StateT Delta (MaybeT DsM) ()+    data_con_app x dc args = pm_alt_con_app x (PmAltConLike (RealDataCon dc)) args++    pm_lit :: Id -> PmLit -> StateT Delta (MaybeT DsM) ()+    pm_lit x lit = pm_alt_con_app x (PmAltLit lit) []++    -- | Adds the given constructor application as a solution for @x@.+    pm_alt_con_app :: Id -> PmAltCon -> [Id] -> StateT Delta (MaybeT DsM) ()+    pm_alt_con_app x con args = modifyT $ \delta -> addVarConCt delta x con args++-- | Like 'modify', but with an effectful modifier action+modifyT :: Monad m => (s -> m s) -> StateT s m ()+modifyT f = StateT $ fmap ((,) ()) . f++{- Note [Detecting pattern synonym applications in expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+At the moment we fail to detect pattern synonyms in scrutinees and RHS of+guards. This could be alleviated with considerable effort and complexity, but+the returns are meager. Consider:++    pattern P+    pattern Q+    case P 15 of+      Q _  -> ...+      P 15 ->++Compared to the situation where P and Q are DataCons, the lack of generativity+means we could never flag Q as redundant.+(also see Note [Undecidable Equality for PmAltCons] in PmTypes.)+On the other hand, if we fail to recognise the pattern synonym, we flag the+pattern match as inexhaustive. That wouldn't happen if we had knowledge about+the scrutinee, in which case the oracle basically knows "If it's a P, then its+field is 15".++This is a pretty narrow use case and I don't think we should to try to fix it+until a user complains energetically.+-}
+ compiler/GHC/HsToCore/PmCheck/Ppr.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE CPP, ViewPatterns #-}++-- | Provides factilities for pretty-printing 'Delta's in a way appropriate for+-- user facing pattern match warnings.+module GHC.HsToCore.PmCheck.Ppr (+        pprUncovered+    ) where++#include "HsVersions.h"++import GhcPrelude++import BasicTypes+import Id+import VarEnv+import UniqDFM+import ConLike+import DataCon+import TysWiredIn+import Outputable+import Control.Monad.Trans.RWS.CPS+import Util+import Maybes+import Data.List.NonEmpty (NonEmpty, nonEmpty, toList)++import GHC.HsToCore.PmCheck.Types+import GHC.HsToCore.PmCheck.Oracle++-- | Pretty-print the guts of an uncovered value vector abstraction, i.e., its+-- components and refutable shapes associated to any mentioned variables.+--+-- Example for @([Just p, q], [p :-> [3,4], q :-> [0,5]]):+--+-- @+-- (Just p) q+--     where p is not one of {3, 4}+--           q is not one of {0, 5}+-- @+--+-- When the set of refutable shapes contains more than 3 elements, the+-- additional elements are indicated by "...".+pprUncovered :: Delta -> [Id] -> SDoc+pprUncovered delta vas+  | isNullUDFM refuts = fsep vec -- there are no refutations+  | otherwise         = hang (fsep vec) 4 $+                          text "where" <+> vcat (map (pprRefutableShapes . snd) (udfmToList refuts))+  where+    init_prec+      -- No outer parentheses when it's a unary pattern by assuming lowest+      -- precedence+      | [_] <- vas   = topPrec+      | otherwise    = appPrec+    ppr_action       = mapM (pprPmVar init_prec) vas+    (vec, renamings) = runPmPpr delta ppr_action+    refuts           = prettifyRefuts delta renamings++-- | Output refutable shapes of a variable in the form of @var is not one of {2,+-- Nothing, 3}@. Will never print more than 3 refutable shapes, the tail is+-- indicated by an ellipsis.+pprRefutableShapes :: (SDoc,[PmAltCon]) -> SDoc+pprRefutableShapes (var, alts)+  = var <+> text "is not one of" <+> format_alts alts+  where+    format_alts = braces . fsep . punctuate comma . shorten . map ppr_alt+    shorten (a:b:c:_:_)       = a:b:c:[text "..."]+    shorten xs                = xs+    ppr_alt (PmAltConLike cl) = ppr cl+    ppr_alt (PmAltLit lit)    = ppr lit++{- 1. Literals+~~~~~~~~~~~~~~+Starting with a function definition like:++    f :: Int -> Bool+    f 5 = True+    f 6 = True++The uncovered set looks like:+    { var |> var /= 5, var /= 6 }++Yet, we would like to print this nicely as follows:+   x , where x not one of {5,6}++Since these variables will be shown to the programmer, we give them better names+(t1, t2, ..) in 'prettifyRefuts', hence the SDoc in 'PrettyPmRefutEnv'.++2. Residual Constraints+~~~~~~~~~~~~~~~~~~~~~~~+Unhandled constraints that refer to HsExpr are typically ignored by the solver+(it does not even substitute in HsExpr so they are even printed as wildcards).+Additionally, the oracle returns a substitution if it succeeds so we apply this+substitution to the vectors before printing them out (see function `pprOne' in+Check.hs) to be more precise.+-}++-- | Extract and assigns pretty names to constraint variables with refutable+-- shapes.+prettifyRefuts :: Delta -> DIdEnv SDoc -> DIdEnv (SDoc, [PmAltCon])+prettifyRefuts delta = listToUDFM . map attach_refuts . udfmToList+  where+    attach_refuts (u, sdoc) = (u, (sdoc, lookupRefuts delta u))+++type PmPprM a = RWS Delta () (DIdEnv SDoc, [SDoc]) a++-- Try nice names p,q,r,s,t before using the (ugly) t_i+nameList :: [SDoc]+nameList = map text ["p","q","r","s","t"] +++            [ text ('t':show u) | u <- [(0 :: Int)..] ]++runPmPpr :: Delta -> PmPprM a -> (a, DIdEnv SDoc)+runPmPpr delta m = case runRWS m delta (emptyDVarEnv, nameList) of+  (a, (renamings, _), _) -> (a, renamings)++-- | Allocates a new, clean name for the given 'Id' if it doesn't already have+-- one.+getCleanName :: Id -> PmPprM SDoc+getCleanName x = do+  (renamings, name_supply) <- get+  let (clean_name:name_supply') = name_supply+  case lookupDVarEnv renamings x of+    Just nm -> pure nm+    Nothing -> do+      put (extendDVarEnv renamings x clean_name, name_supply')+      pure clean_name++checkRefuts :: Id -> PmPprM (Maybe SDoc) -- the clean name if it has negative info attached+checkRefuts x = do+  delta <- ask+  case lookupRefuts delta x of+    [] -> pure Nothing -- Will just be a wildcard later on+    _  -> Just <$> getCleanName x++-- | Pretty print a variable, but remember to prettify the names of the variables+-- that refer to neg-literals. The ones that cannot be shown are printed as+-- underscores. Even with a type signature, if it's not too noisy.+pprPmVar :: PprPrec -> Id -> PmPprM SDoc+-- Type signature is "too noisy" by my definition if it needs to parenthesize.+-- I like           "not matched: _ :: Proxy (DIdEnv SDoc)",+-- but I don't like "not matched: (_ :: stuff) (_:_) (_ :: Proxy (DIdEnv SDoc))"+-- The useful information in the latter case is the constructor that we missed,+-- not the types of the wildcards in the places that aren't matched as a result.+pprPmVar prec x = do+  delta <- ask+  case lookupSolution delta x of+    Just (alt, args) -> pprPmAltCon prec alt args+    Nothing          -> fromMaybe typed_wildcard <$> checkRefuts x+      where+        -- if we have no info about the parameter and would just print a+        -- wildcard, also show its type.+        typed_wildcard+          | prec <= sigPrec+          = underscore <+> text "::" <+> ppr (idType x)+          | otherwise+          = underscore++pprPmAltCon :: PprPrec -> PmAltCon -> [Id] -> PmPprM SDoc+pprPmAltCon _prec (PmAltLit l)      _    = pure (ppr l)+pprPmAltCon prec  (PmAltConLike cl) args = do+  delta <- ask+  pprConLike delta prec cl args++pprConLike :: Delta -> PprPrec -> ConLike -> [Id] -> PmPprM SDoc+pprConLike delta _prec cl args+  | Just pm_expr_list <- pmExprAsList delta (PmAltConLike cl) args+  = case pm_expr_list of+      NilTerminated list ->+        brackets . fsep . punctuate comma <$> mapM (pprPmVar appPrec) list+      WcVarTerminated pref x ->+        parens   . fcat . punctuate colon <$> mapM (pprPmVar appPrec) (toList pref ++ [x])+pprConLike _delta _prec (RealDataCon con) args+  | isUnboxedTupleCon con+  , let hash_parens doc = text "(#" <+> doc <+> text "#)"+  = hash_parens . fsep . punctuate comma <$> mapM (pprPmVar appPrec) args+  | isTupleDataCon con+  = parens . fsep . punctuate comma <$> mapM (pprPmVar appPrec) args+pprConLike _delta prec cl args+  | conLikeIsInfix cl = case args of+      [x, y] -> do x' <- pprPmVar funPrec x+                   y' <- pprPmVar funPrec y+                   return (cparen (prec > opPrec) (x' <+> ppr cl <+> y'))+      -- can it be infix but have more than two arguments?+      list   -> pprPanic "pprConLike:" (ppr list)+  | null args = return (ppr cl)+  | otherwise = do args' <- mapM (pprPmVar appPrec) args+                   return (cparen (prec > funPrec) (fsep (ppr cl : args')))++-- | The result of 'pmExprAsList'.+data PmExprList+  = NilTerminated [Id]+  | WcVarTerminated (NonEmpty Id) Id++-- | Extract a list of 'Id's out of a sequence of cons cells, optionally+-- terminated by a wildcard variable instead of @[]@. Some examples:+--+-- * @pmExprAsList (1:2:[]) == Just ('NilTerminated' [1,2])@, a regular,+--   @[]@-terminated list. Should be pretty-printed as @[1,2]@.+-- * @pmExprAsList (1:2:x) == Just ('WcVarTerminated' [1,2] x)@, a list prefix+--   ending in a wildcard variable x (of list type). Should be pretty-printed as+--   (1:2:_).+-- * @pmExprAsList [] == Just ('NilTerminated' [])@+pmExprAsList :: Delta -> PmAltCon -> [Id] -> Maybe PmExprList+pmExprAsList delta = go_con []+  where+    go_var rev_pref x+      | Just (alt, args) <- lookupSolution delta x+      = go_con rev_pref alt args+    go_var rev_pref x+      | Just pref <- nonEmpty (reverse rev_pref)+      = Just (WcVarTerminated pref x)+    go_var _ _+      = Nothing++    go_con rev_pref (PmAltConLike (RealDataCon c)) es+      | c == nilDataCon+      = ASSERT( null es ) Just (NilTerminated (reverse rev_pref))+      | c == consDataCon+      = ASSERT( length es == 2 ) go_var (es !! 0 : rev_pref) (es !! 1)+    go_con _ _ _+      = Nothing
+ compiler/GHC/Platform/ARM.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}++module GHC.Platform.ARM where++import GhcPrelude++#define MACHREGS_NO_REGS 0+#define MACHREGS_arm 1+#include "../../../includes/CodeGen.Platform.hs"+
+ compiler/GHC/Platform/ARM64.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}++module GHC.Platform.ARM64 where++import GhcPrelude++#define MACHREGS_NO_REGS 0+#define MACHREGS_aarch64 1+#include "../../../includes/CodeGen.Platform.hs"+
+ compiler/GHC/Platform/NoRegs.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE CPP #-}++module GHC.Platform.NoRegs where++import GhcPrelude++#define MACHREGS_NO_REGS 1+#include "../../../includes/CodeGen.Platform.hs"+
+ compiler/GHC/Platform/PPC.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}++module GHC.Platform.PPC where++import GhcPrelude++#define MACHREGS_NO_REGS 0+#define MACHREGS_powerpc 1+#include "../../../includes/CodeGen.Platform.hs"+
+ compiler/GHC/Platform/Regs.hs view
@@ -0,0 +1,113 @@++module GHC.Platform.Regs+       (callerSaves, activeStgRegs, haveRegBase, globalRegMaybe, freeReg)+       where++import GhcPrelude++import CmmExpr+import GHC.Platform+import Reg++import qualified GHC.Platform.ARM        as ARM+import qualified GHC.Platform.ARM64      as ARM64+import qualified GHC.Platform.PPC        as PPC+import qualified GHC.Platform.S390X      as S390X+import qualified GHC.Platform.SPARC      as SPARC+import qualified GHC.Platform.X86        as X86+import qualified GHC.Platform.X86_64     as X86_64+import qualified GHC.Platform.NoRegs     as NoRegs++-- | Returns 'True' if this global register is stored in a caller-saves+-- machine register.++callerSaves :: Platform -> GlobalReg -> Bool+callerSaves platform+ | platformUnregisterised platform = NoRegs.callerSaves+ | otherwise+ = case platformArch platform of+   ArchX86    -> X86.callerSaves+   ArchX86_64 -> X86_64.callerSaves+   ArchS390X  -> S390X.callerSaves+   ArchSPARC  -> SPARC.callerSaves+   ArchARM {} -> ARM.callerSaves+   ArchARM64  -> ARM64.callerSaves+   arch+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->+        PPC.callerSaves++    | otherwise -> NoRegs.callerSaves++-- | Here is where the STG register map is defined for each target arch.+-- The order matters (for the llvm backend anyway)! We must make sure to+-- maintain the order here with the order used in the LLVM calling conventions.+-- Note that also, this isn't all registers, just the ones that are currently+-- possbily mapped to real registers.+activeStgRegs :: Platform -> [GlobalReg]+activeStgRegs platform+ | platformUnregisterised platform = NoRegs.activeStgRegs+ | otherwise+ = case platformArch platform of+   ArchX86    -> X86.activeStgRegs+   ArchX86_64 -> X86_64.activeStgRegs+   ArchS390X  -> S390X.activeStgRegs+   ArchSPARC  -> SPARC.activeStgRegs+   ArchARM {} -> ARM.activeStgRegs+   ArchARM64  -> ARM64.activeStgRegs+   arch+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->+        PPC.activeStgRegs++    | otherwise -> NoRegs.activeStgRegs++haveRegBase :: Platform -> Bool+haveRegBase platform+ | platformUnregisterised platform = NoRegs.haveRegBase+ | otherwise+ = case platformArch platform of+   ArchX86    -> X86.haveRegBase+   ArchX86_64 -> X86_64.haveRegBase+   ArchS390X  -> S390X.haveRegBase+   ArchSPARC  -> SPARC.haveRegBase+   ArchARM {} -> ARM.haveRegBase+   ArchARM64  -> ARM64.haveRegBase+   arch+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->+        PPC.haveRegBase++    | otherwise -> NoRegs.haveRegBase++globalRegMaybe :: Platform -> GlobalReg -> Maybe RealReg+globalRegMaybe platform+ | platformUnregisterised platform = NoRegs.globalRegMaybe+ | otherwise+ = case platformArch platform of+   ArchX86    -> X86.globalRegMaybe+   ArchX86_64 -> X86_64.globalRegMaybe+   ArchS390X  -> S390X.globalRegMaybe+   ArchSPARC  -> SPARC.globalRegMaybe+   ArchARM {} -> ARM.globalRegMaybe+   ArchARM64  -> ARM64.globalRegMaybe+   arch+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->+        PPC.globalRegMaybe++    | otherwise -> NoRegs.globalRegMaybe++freeReg :: Platform -> RegNo -> Bool+freeReg platform+ | platformUnregisterised platform = NoRegs.freeReg+ | otherwise+ = case platformArch platform of+   ArchX86    -> X86.freeReg+   ArchX86_64 -> X86_64.freeReg+   ArchS390X  -> S390X.freeReg+   ArchSPARC  -> SPARC.freeReg+   ArchARM {} -> ARM.freeReg+   ArchARM64  -> ARM64.freeReg+   arch+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->+        PPC.freeReg++    | otherwise -> NoRegs.freeReg+
+ compiler/GHC/Platform/S390X.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}++module GHC.Platform.S390X where++import GhcPrelude++#define MACHREGS_NO_REGS 0+#define MACHREGS_s390x 1+#include "../../../includes/CodeGen.Platform.hs"+
+ compiler/GHC/Platform/SPARC.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}++module GHC.Platform.SPARC where++import GhcPrelude++#define MACHREGS_NO_REGS 0+#define MACHREGS_sparc 1+#include "../../../includes/CodeGen.Platform.hs"+
+ compiler/GHC/Platform/X86.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}++module GHC.Platform.X86 where++import GhcPrelude++#define MACHREGS_NO_REGS 0+#define MACHREGS_i386 1+#include "../../../includes/CodeGen.Platform.hs"+
+ compiler/GHC/Platform/X86_64.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}++module GHC.Platform.X86_64 where++import GhcPrelude++#define MACHREGS_NO_REGS 0+#define MACHREGS_x86_64 1+#include "../../../includes/CodeGen.Platform.hs"+
+ compiler/GHC/StgToCmm.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}++-----------------------------------------------------------------------------+--+-- Stg to C-- code generation+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm ( codeGen ) where++#include "HsVersions.h"++import GhcPrelude as Prelude++import GHC.StgToCmm.Prof (initCostCentres, ldvEnter)+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Env+import GHC.StgToCmm.Bind+import GHC.StgToCmm.DataCon+import GHC.StgToCmm.Layout+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Closure+import GHC.StgToCmm.Hpc+import GHC.StgToCmm.Ticky++import Cmm+import CmmUtils+import CLabel++import StgSyn+import DynFlags+import ErrUtils++import HscTypes+import CostCentre+import Id+import IdInfo+import RepType+import DataCon+import TyCon+import Module+import Outputable+import Stream+import BasicTypes+import VarSet ( isEmptyDVarSet )++import OrdList+import MkGraph++import Data.IORef+import Control.Monad (when,void)+import Util++codeGen :: DynFlags+        -> Module+        -> [TyCon]+        -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.+        -> [CgStgTopBinding]           -- Bindings to convert+        -> HpcInfo+        -> Stream IO CmmGroup ()       -- Output as a stream, so codegen can+                                       -- be interleaved with output++codeGen dflags this_mod data_tycons+        cost_centre_info stg_binds hpc_info+  = do  {     -- cg: run the code generator, and yield the resulting CmmGroup+              -- Using an IORef to store the state is a bit crude, but otherwise+              -- we would need to add a state monad layer.+        ; cgref <- liftIO $ newIORef =<< initC+        ; let cg :: FCode () -> Stream IO CmmGroup ()+              cg fcode = do+                cmm <- liftIO . withTimingSilent dflags (text "STG -> Cmm") (`seq` ()) $ do+                         st <- readIORef cgref+                         let (a,st') = runC dflags this_mod st (getCmm fcode)++                         -- NB. stub-out cgs_tops and cgs_stmts.  This fixes+                         -- a big space leak.  DO NOT REMOVE!+                         writeIORef cgref $! st'{ cgs_tops = nilOL,+                                                  cgs_stmts = mkNop }+                         return a+                yield cmm++               -- Note [codegen-split-init] the cmm_init block must come+               -- FIRST.  This is because when -split-objs is on we need to+               -- combine this block with its initialisation routines; see+               -- Note [pipeline-split-init].+        ; cg (mkModuleInit cost_centre_info this_mod hpc_info)++        ; mapM_ (cg . cgTopBinding dflags) stg_binds++                -- Put datatype_stuff after code_stuff, because the+                -- datatype closure table (for enumeration types) to+                -- (say) PrelBase_True_closure, which is defined in+                -- code_stuff+        ; let do_tycon tycon = do+                -- Generate a table of static closures for an+                -- enumeration type Note that the closure pointers are+                -- tagged.+                 when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)+                 mapM_ (cg . cgDataCon) (tyConDataCons tycon)++        ; mapM_ do_tycon data_tycons+        }++---------------------------------------------------------------+--      Top-level bindings+---------------------------------------------------------------++{- 'cgTopBinding' is only used for top-level bindings, since they need+to be allocated statically (not in the heap) and need to be labelled.+No unboxed bindings can happen at top level.++In the code below, the static bindings are accumulated in the+@MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.+This is so that we can write the top level processing in a compositional+style, with the increasing static environment being plumbed as a state+variable. -}++cgTopBinding :: DynFlags -> CgStgTopBinding -> FCode ()+cgTopBinding dflags (StgTopLifted (StgNonRec id rhs))+  = do  { let (info, fcode) = cgTopRhs dflags NonRecursive id rhs+        ; fcode+        ; addBindC info+        }++cgTopBinding dflags (StgTopLifted (StgRec pairs))+  = do  { let (bndrs, rhss) = unzip pairs+        ; let pairs' = zip bndrs rhss+              r = unzipWith (cgTopRhs dflags Recursive) pairs'+              (infos, fcodes) = unzip r+        ; addBindsC infos+        ; sequence_ fcodes+        }++cgTopBinding dflags (StgTopStringLit id str)+  = do  { let label = mkBytesLabel (idName id)+        ; let (lit, decl) = mkByteStringCLit label str+        ; emitDecl decl+        ; addBindC (litIdInfo dflags id mkLFStringLit lit)+        }++cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())+        -- The Id is passed along for setting up a binding...++cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)+  = cgTopRhsCon dflags bndr con (assertNonVoidStgArgs args)+      -- con args are always non-void,+      -- see Note [Post-unarisation invariants] in UnariseStg++cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body)+  = ASSERT(isEmptyDVarSet fvs)    -- There should be no free variables+    cgTopRhsClosure dflags rec bndr cc upd_flag args body+++---------------------------------------------------------------+--      Module initialisation code+---------------------------------------------------------------++mkModuleInit+        :: CollectedCCs         -- cost centre info+        -> Module+        -> HpcInfo+        -> FCode ()++mkModuleInit cost_centre_info this_mod hpc_info+  = do  { initHpc this_mod hpc_info+        ; initCostCentres cost_centre_info+        }+++---------------------------------------------------------------+--      Generating static stuff for algebraic data types+---------------------------------------------------------------+++cgEnumerationTyCon :: TyCon -> FCode ()+cgEnumerationTyCon tycon+  = do dflags <- getDynFlags+       emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)+             [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)+                           (tagForCon dflags con)+             | con <- tyConDataCons tycon]+++cgDataCon :: DataCon -> FCode ()+-- Generate the entry code, info tables, and (for niladic constructor)+-- the static closure, for a constructor.+cgDataCon data_con+  = do  { dflags <- getDynFlags+        ; let+            (tot_wds, --  #ptr_wds + #nonptr_wds+             ptr_wds) --  #ptr_wds+              = mkVirtConstrSizes dflags arg_reps++            nonptr_wds   = tot_wds - ptr_wds++            dyn_info_tbl =+              mkDataConInfoTable dflags data_con False ptr_wds nonptr_wds++            -- We're generating info tables, so we don't know and care about+            -- what the actual arguments are. Using () here as the place holder.+            arg_reps :: [NonVoid PrimRep]+            arg_reps = [ NonVoid rep_ty+                       | ty <- dataConRepArgTys data_con+                       , rep_ty <- typePrimRep ty+                       , not (isVoidRep rep_ty) ]++        ; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $+            -- NB: the closure pointer is assumed *untagged* on+            -- entry to a constructor.  If the pointer is tagged,+            -- then we should not be entering it.  This assumption+            -- is used in ldvEnter and when tagging the pointer to+            -- return it.+            -- NB 2: We don't set CC when entering data (WDP 94/06)+            do { tickyEnterDynCon+               ; ldvEnter (CmmReg nodeReg)+               ; tickyReturnOldCon (length arg_reps)+               ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) (tagForCon dflags data_con)]+               }+                    -- The case continuation code expects a tagged pointer+        }
+ compiler/GHC/StgToCmm/ArgRep.hs view
@@ -0,0 +1,160 @@+-----------------------------------------------------------------------------+--+-- Argument representations used in GHC.StgToCmm.Layout.+--+-- (c) The University of Glasgow 2013+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.ArgRep (+        ArgRep(..), toArgRep, argRepSizeW,++        argRepString, isNonV, idArgRep,++        slowCallPattern,++        ) where++import GhcPrelude++import GHC.StgToCmm.Closure ( idPrimRep )++import SMRep            ( WordOff )+import Id               ( Id )+import TyCon            ( PrimRep(..), primElemRepSizeB )+import BasicTypes       ( RepArity )+import Constants        ( wORD64_SIZE )+import DynFlags++import Outputable+import FastString++-- I extricated this code as this new module in order to avoid a+-- cyclic dependency between GHC.StgToCmm.Layout and GHC.StgToCmm.Ticky.+--+-- NSF 18 Feb 2013++-------------------------------------------------------------------------+--      Classifying arguments: ArgRep+-------------------------------------------------------------------------++-- ArgRep is re-exported by GHC.StgToCmm.Layout, but only for use in the+-- byte-code generator which also needs to know about the+-- classification of arguments.++data ArgRep = P   -- GC Ptr+            | N   -- Word-sized non-ptr+            | L   -- 64-bit non-ptr (long)+            | V   -- Void+            | F   -- Float+            | D   -- Double+            | V16 -- 16-byte (128-bit) vectors of Float/Double/Int8/Word32/etc.+            | V32 -- 32-byte (256-bit) vectors of Float/Double/Int8/Word32/etc.+            | V64 -- 64-byte (512-bit) vectors of Float/Double/Int8/Word32/etc.+instance Outputable ArgRep where ppr = text . argRepString++argRepString :: ArgRep -> String+argRepString P = "P"+argRepString N = "N"+argRepString L = "L"+argRepString V = "V"+argRepString F = "F"+argRepString D = "D"+argRepString V16 = "V16"+argRepString V32 = "V32"+argRepString V64 = "V64"++toArgRep :: PrimRep -> ArgRep+toArgRep VoidRep           = V+toArgRep LiftedRep         = P+toArgRep UnliftedRep       = P+toArgRep IntRep            = N+toArgRep WordRep           = N+toArgRep Int8Rep           = N  -- Gets widened to native word width for calls+toArgRep Word8Rep          = N  -- Gets widened to native word width for calls+toArgRep Int16Rep          = N  -- Gets widened to native word width for calls+toArgRep Word16Rep         = N  -- Gets widened to native word width for calls+toArgRep Int32Rep          = N  -- Gets widened to native word width for calls+toArgRep Word32Rep         = N  -- Gets widened to native word width for calls+toArgRep AddrRep           = N+toArgRep Int64Rep          = L+toArgRep Word64Rep         = L+toArgRep FloatRep          = F+toArgRep DoubleRep         = D+toArgRep (VecRep len elem) = case len*primElemRepSizeB elem of+                               16 -> V16+                               32 -> V32+                               64 -> V64+                               _  -> error "toArgRep: bad vector primrep"++isNonV :: ArgRep -> Bool+isNonV V = False+isNonV _ = True++argRepSizeW :: DynFlags -> ArgRep -> WordOff                -- Size in words+argRepSizeW _      N   = 1+argRepSizeW _      P   = 1+argRepSizeW _      F   = 1+argRepSizeW dflags L   = wORD64_SIZE        `quot` wORD_SIZE dflags+argRepSizeW dflags D   = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags+argRepSizeW _      V   = 0+argRepSizeW dflags V16 = 16                 `quot` wORD_SIZE dflags+argRepSizeW dflags V32 = 32                 `quot` wORD_SIZE dflags+argRepSizeW dflags V64 = 64                 `quot` wORD_SIZE dflags++idArgRep :: Id -> ArgRep+idArgRep = toArgRep . idPrimRep++-- This list of argument patterns should be kept in sync with at least+-- the following:+--+--  * GHC.StgToCmm.Layout.stdPattern maybe to some degree?+--+--  * the RTS_RET(stg_ap_*) and RTS_FUN_DECL(stg_ap_*_fast)+--  declarations in includes/stg/MiscClosures.h+--+--  * the SLOW_CALL_*_ctr declarations in includes/stg/Ticky.h,+--+--  * the TICK_SLOW_CALL_*() #defines in includes/Cmm.h,+--+--  * the PR_CTR(SLOW_CALL_*_ctr) calls in rts/Ticky.c,+--+--  * and the SymI_HasProto(stg_ap_*_{ret,info,fast}) calls and+--  SymI_HasProto(SLOW_CALL_*_ctr) calls in rts/Linker.c+--+-- There may be more places that I haven't found; I merely igrep'd for+-- pppppp and excluded things that seemed ghci-specific.+--+-- Also, it seems at the moment that ticky counters with void+-- arguments will never be bumped, but I'm still declaring those+-- counters, defensively.+--+-- NSF 6 Mar 2013++slowCallPattern :: [ArgRep] -> (FastString, RepArity)+-- Returns the generic apply function and arity+--+-- The first batch of cases match (some) specialised entries+-- The last group deals exhaustively with the cases for the first argument+--   (and the zero-argument case)+--+-- In 99% of cases this function will match *all* the arguments in one batch++slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6)+slowCallPattern (P: P: P: P: P: _)    = (fsLit "stg_ap_ppppp", 5)+slowCallPattern (P: P: P: P: _)       = (fsLit "stg_ap_pppp", 4)+slowCallPattern (P: P: P: V: _)       = (fsLit "stg_ap_pppv", 4)+slowCallPattern (P: P: P: _)          = (fsLit "stg_ap_ppp", 3)+slowCallPattern (P: P: V: _)          = (fsLit "stg_ap_ppv", 3)+slowCallPattern (P: P: _)             = (fsLit "stg_ap_pp", 2)+slowCallPattern (P: V: _)             = (fsLit "stg_ap_pv", 2)+slowCallPattern (P: _)                = (fsLit "stg_ap_p", 1)+slowCallPattern (V: _)                = (fsLit "stg_ap_v", 1)+slowCallPattern (N: _)                = (fsLit "stg_ap_n", 1)+slowCallPattern (F: _)                = (fsLit "stg_ap_f", 1)+slowCallPattern (D: _)                = (fsLit "stg_ap_d", 1)+slowCallPattern (L: _)                = (fsLit "stg_ap_l", 1)+slowCallPattern (V16: _)              = (fsLit "stg_ap_v16", 1)+slowCallPattern (V32: _)              = (fsLit "stg_ap_v32", 1)+slowCallPattern (V64: _)              = (fsLit "stg_ap_v64", 1)+slowCallPattern []                    = (fsLit "stg_ap_0", 0)
+ compiler/GHC/StgToCmm/Bind.hs view
@@ -0,0 +1,754 @@+-----------------------------------------------------------------------------+--+-- Stg to C-- code generation: bindings+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Bind (+        cgTopRhsClosure,+        cgBind,+        emitBlackHoleCode,+        pushUpdateFrame, emitUpdateFrame+  ) where++import GhcPrelude hiding ((<*>))++import GHC.StgToCmm.Expr+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Env+import GHC.StgToCmm.DataCon+import GHC.StgToCmm.Heap+import GHC.StgToCmm.Prof (ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk,+                   initUpdFrameProf)+import GHC.StgToCmm.Ticky+import GHC.StgToCmm.Layout+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Closure+import GHC.StgToCmm.Foreign    (emitPrimCall)++import MkGraph+import CoreSyn          ( AltCon(..), tickishIsCode )+import BlockId+import SMRep+import Cmm+import CmmInfo+import CmmUtils+import CLabel+import StgSyn+import CostCentre+import Id+import IdInfo+import Name+import Module+import ListSetOps+import Util+import VarSet+import BasicTypes+import Outputable+import FastString+import DynFlags++import Control.Monad++------------------------------------------------------------------------+--              Top-level bindings+------------------------------------------------------------------------++-- For closures bound at top level, allocate in static space.+-- They should have no free variables.++cgTopRhsClosure :: DynFlags+                -> RecFlag              -- member of a recursive group?+                -> Id+                -> CostCentreStack      -- Optional cost centre annotation+                -> UpdateFlag+                -> [Id]                 -- Args+                -> CgStgExpr+                -> (CgIdInfo, FCode ())++cgTopRhsClosure dflags rec id ccs upd_flag args body =+  let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)+      cg_id_info    = litIdInfo dflags id lf_info (CmmLabel closure_label)+      lf_info       = mkClosureLFInfo dflags id TopLevel [] upd_flag args+  in (cg_id_info, gen_code dflags lf_info closure_label)+  where+  -- special case for a indirection (f = g).  We create an IND_STATIC+  -- closure pointing directly to the indirectee.  This is exactly+  -- what the CAF will eventually evaluate to anyway, we're just+  -- shortcutting the whole process, and generating a lot less code+  -- (#7308). Eventually the IND_STATIC closure will be eliminated+  -- by assembly '.equiv' directives, where possible (#15155).+  -- See note [emit-time elimination of static indirections] in CLabel.+  --+  -- Note: we omit the optimisation when this binding is part of a+  -- recursive group, because the optimisation would inhibit the black+  -- hole detection from working in that case.  Test+  -- concurrent/should_run/4030 fails, for instance.+  --+  gen_code dflags _ closure_label+    | StgApp f [] <- body, null args, isNonRec rec+    = do+         cg_info <- getCgIdInfo f+         let closure_rep   = mkStaticClosureFields dflags+                                    indStaticInfoTable ccs MayHaveCafRefs+                                    [unLit (idInfoToAmode cg_info)]+         emitDataLits closure_label closure_rep+         return ()++  gen_code dflags lf_info _closure_label+   = do { let name = idName id+        ; mod_name <- getModuleName+        ; let descr         = closureDescription dflags mod_name name+              closure_info  = mkClosureInfo dflags True id lf_info 0 0 descr++        -- We don't generate the static closure here, because we might+        -- want to add references to static closures to it later.  The+        -- static closure is generated by CmmBuildInfoTables.updInfoSRTs,+        -- See Note [SRTs], specifically the [FUN] optimisation.++        ; let fv_details :: [(NonVoid Id, ByteOff)]+              header = if isLFThunk lf_info then ThunkHeader else StdHeader+              (_, _, fv_details) = mkVirtHeapOffsets dflags header []+        -- Don't drop the non-void args until the closure info has been made+        ; forkClosureBody (closureCodeBody True id closure_info ccs+                                (nonVoidIds args) (length args) body fv_details)++        ; return () }++  unLit (CmmLit l) = l+  unLit _ = panic "unLit"++------------------------------------------------------------------------+--              Non-top-level bindings+------------------------------------------------------------------------++cgBind :: CgStgBinding -> FCode ()+cgBind (StgNonRec name rhs)+  = do  { (info, fcode) <- cgRhs name rhs+        ; addBindC info+        ; init <- fcode+        ; emit init }+        -- init cannot be used in body, so slightly better to sink it eagerly++cgBind (StgRec pairs)+  = do  {  r <- sequence $ unzipWith cgRhs pairs+        ;  let (id_infos, fcodes) = unzip r+        ;  addBindsC id_infos+        ;  (inits, body) <- getCodeR $ sequence fcodes+        ;  emit (catAGraphs inits <*> body) }++{- Note [cgBind rec]++   Recursive let-bindings are tricky.+   Consider the following pseudocode:++     let x = \_ ->  ... y ...+         y = \_ ->  ... z ...+         z = \_ ->  ... x ...+     in ...++   For each binding, we need to allocate a closure, and each closure must+   capture the address of the other closures.+   We want to generate the following C-- code:+     // Initialization Code+     x = hp - 24; // heap address of x's closure+     y = hp - 40; // heap address of x's closure+     z = hp - 64; // heap address of x's closure+     // allocate and initialize x+     m[hp-8]   = ...+     m[hp-16]  = y       // the closure for x captures y+     m[hp-24] = x_info;+     // allocate and initialize y+     m[hp-32] = z;       // the closure for y captures z+     m[hp-40] = y_info;+     // allocate and initialize z+     ...++   For each closure, we must generate not only the code to allocate and+   initialize the closure itself, but also some initialization Code that+   sets a variable holding the closure pointer.++   We could generate a pair of the (init code, body code), but since+   the bindings are recursive we also have to initialise the+   environment with the CgIdInfo for all the bindings before compiling+   anything.  So we do this in 3 stages:++     1. collect all the CgIdInfos and initialise the environment+     2. compile each binding into (init, body) code+     3. emit all the inits, and then all the bodies++   We'd rather not have separate functions to do steps 1 and 2 for+   each binding, since in pratice they share a lot of code.  So we+   have just one function, cgRhs, that returns a pair of the CgIdInfo+   for step 1, and a monadic computation to generate the code in step+   2.++   The alternative to separating things in this way is to use a+   fixpoint.  That's what we used to do, but it introduces a+   maintenance nightmare because there is a subtle dependency on not+   being too strict everywhere.  Doing things this way means that the+   FCode monad can be strict, for example.+ -}++cgRhs :: Id+      -> CgStgRhs+      -> FCode (+                 CgIdInfo         -- The info for this binding+               , FCode CmmAGraph  -- A computation which will generate the+                                  -- code for the binding, and return an+                                  -- assignent of the form "x = Hp - n"+                                  -- (see above)+               )++cgRhs id (StgRhsCon cc con args)+  = withNewTickyCounterCon (idName id) $+    buildDynCon id True cc con (assertNonVoidStgArgs args)+      -- con args are always non-void,+      -- see Note [Post-unarisation invariants] in UnariseStg++{- See Note [GC recovery] in compiler/GHC.StgToCmm/Closure.hs -}+cgRhs id (StgRhsClosure fvs cc upd_flag args body)+  = do dflags <- getDynFlags+       mkRhsClosure dflags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body++------------------------------------------------------------------------+--              Non-constructor right hand sides+------------------------------------------------------------------------++mkRhsClosure :: DynFlags -> Id -> CostCentreStack+             -> [NonVoid Id]                    -- Free vars+             -> UpdateFlag+             -> [Id]                            -- Args+             -> CgStgExpr+             -> FCode (CgIdInfo, FCode CmmAGraph)++{- mkRhsClosure looks for two special forms of the right-hand side:+        a) selector thunks+        b) AP thunks++If neither happens, it just calls mkClosureLFInfo.  You might think+that mkClosureLFInfo should do all this, but it seems wrong for the+latter to look at the structure of an expression++Note [Selectors]+~~~~~~~~~~~~~~~~+We look at the body of the closure to see if it's a selector---turgid,+but nothing deep.  We are looking for a closure of {\em exactly} the+form:++...  = [the_fv] \ u [] ->+         case the_fv of+           con a_1 ... a_n -> a_i++Note [Ap thunks]+~~~~~~~~~~~~~~~~+A more generic AP thunk of the form++        x = [ x_1...x_n ] \.. [] -> x_1 ... x_n++A set of these is compiled statically into the RTS, so we just use+those.  We could extend the idea to thunks where some of the x_i are+global ids (and hence not free variables), but this would entail+generating a larger thunk.  It might be an option for non-optimising+compilation, though.++We only generate an Ap thunk if all the free variables are pointers,+for semi-obvious reasons.++-}++---------- Note [Selectors] ------------------+mkRhsClosure    dflags bndr _cc+                [NonVoid the_fv]                -- Just one free var+                upd_flag                -- Updatable thunk+                []                      -- A thunk+                expr+  | let strip = stripStgTicksTopE (not . tickishIsCode)+  , StgCase (StgApp scrutinee [{-no args-}])+         _   -- ignore bndr+         (AlgAlt _)+         [(DataAlt _, params, sel_expr)] <- strip expr+  , StgApp selectee [{-no args-}] <- strip sel_expr+  , the_fv == scrutinee                -- Scrutinee is the only free variable++  , let (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps (assertNonVoidIds params))+                                   -- pattern binders are always non-void,+                                   -- see Note [Post-unarisation invariants] in UnariseStg+  , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee)++  , let offset_into_int = bytesToWordsRoundUp dflags the_offset+                          - fixedHdrSizeW dflags+  , offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough+  = -- NOT TRUE: ASSERT(is_single_constructor)+    -- The simplifier may have statically determined that the single alternative+    -- is the only possible case and eliminated the others, even if there are+    -- other constructors in the datatype.  It's still ok to make a selector+    -- thunk in this case, because we *know* which constructor the scrutinee+    -- will evaluate to.+    --+    -- srt is discarded; it must be empty+    let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)+    in cgRhsStdThunk bndr lf_info [StgVarArg the_fv]++---------- Note [Ap thunks] ------------------+mkRhsClosure    dflags bndr _cc+                fvs+                upd_flag+                []                      -- No args; a thunk+                (StgApp fun_id args)++  -- We are looking for an "ApThunk"; see data con ApThunk in GHC.StgToCmm.Closure+  -- of form (x1 x2 .... xn), where all the xi are locals (not top-level)+  -- So the xi will all be free variables+  | args `lengthIs` (n_fvs-1)  -- This happens only if the fun_id and+                               -- args are all distinct local variables+                               -- The "-1" is for fun_id+    -- Missed opportunity:   (f x x) is not detected+  , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs+  , isUpdatable upd_flag+  , n_fvs <= mAX_SPEC_AP_SIZE dflags+  , not (gopt Opt_SccProfilingOn dflags)+                         -- not when profiling: we don't want to+                         -- lose information about this particular+                         -- thunk (e.g. its type) (#949)+  , idArity fun_id == unknownArity -- don't spoil a known call++          -- Ha! an Ap thunk+  = cgRhsStdThunk bndr lf_info payload++  where+    n_fvs   = length fvs+    lf_info = mkApLFInfo bndr upd_flag n_fvs+    -- the payload has to be in the correct order, hence we can't+    -- just use the fvs.+    payload = StgVarArg fun_id : args++---------- Default case ------------------+mkRhsClosure dflags bndr cc fvs upd_flag args body+  = do  { let lf_info = mkClosureLFInfo dflags bndr NotTopLevel fvs upd_flag args+        ; (id_info, reg) <- rhsIdInfo bndr lf_info+        ; return (id_info, gen_code lf_info reg) }+ where+ gen_code lf_info reg+  = do  {       -- LAY OUT THE OBJECT+        -- If the binder is itself a free variable, then don't store+        -- it in the closure.  Instead, just bind it to Node on entry.+        -- NB we can be sure that Node will point to it, because we+        -- haven't told mkClosureLFInfo about this; so if the binder+        -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*+        -- stored in the closure itself, so it will make sure that+        -- Node points to it...+        ; let   reduced_fvs = filter (NonVoid bndr /=) fvs++        -- MAKE CLOSURE INFO FOR THIS CLOSURE+        ; mod_name <- getModuleName+        ; dflags <- getDynFlags+        ; let   name  = idName bndr+                descr = closureDescription dflags mod_name name+                fv_details :: [(NonVoid Id, ByteOff)]+                header = if isLFThunk lf_info then ThunkHeader else StdHeader+                (tot_wds, ptr_wds, fv_details)+                   = mkVirtHeapOffsets dflags header (addIdReps reduced_fvs)+                closure_info = mkClosureInfo dflags False       -- Not static+                                             bndr lf_info tot_wds ptr_wds+                                             descr++        -- BUILD ITS INFO TABLE AND CODE+        ; forkClosureBody $+                -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere+                --                  (b) ignore Sequel from context; use empty Sequel+                -- And compile the body+                closureCodeBody False bndr closure_info cc (nonVoidIds args)+                                (length args) body fv_details++        -- BUILD THE OBJECT+--      ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body+        ; let use_cc = cccsExpr; blame_cc = cccsExpr+        ; emit (mkComment $ mkFastString "calling allocDynClosure")+        ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)+        ; let info_tbl = mkCmmInfo closure_info bndr currentCCS+        ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc+                                         (map toVarArg fv_details)++        -- RETURN+        ; return (mkRhsInit dflags reg lf_info hp_plus_n) }++-------------------------+cgRhsStdThunk+        :: Id+        -> LambdaFormInfo+        -> [StgArg]             -- payload+        -> FCode (CgIdInfo, FCode CmmAGraph)++cgRhsStdThunk bndr lf_info payload+ = do  { (id_info, reg) <- rhsIdInfo bndr lf_info+       ; return (id_info, gen_code reg)+       }+ where+ gen_code reg  -- AHA!  A STANDARD-FORM THUNK+  = withNewTickyCounterStdThunk (lfUpdatable lf_info) (idName bndr) $+    do+  {     -- LAY OUT THE OBJECT+    mod_name <- getModuleName+  ; dflags <- getDynFlags+  ; let header = if isLFThunk lf_info then ThunkHeader else StdHeader+        (tot_wds, ptr_wds, payload_w_offsets)+            = mkVirtHeapOffsets dflags header+                (addArgReps (nonVoidStgArgs payload))++        descr = closureDescription dflags mod_name (idName bndr)+        closure_info = mkClosureInfo dflags False       -- Not static+                                     bndr lf_info tot_wds ptr_wds+                                     descr++--  ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body+  ; let use_cc = cccsExpr; blame_cc = cccsExpr+++        -- BUILD THE OBJECT+  ; let info_tbl = mkCmmInfo closure_info bndr currentCCS+  ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info+                                   use_cc blame_cc payload_w_offsets++        -- RETURN+  ; return (mkRhsInit dflags reg lf_info hp_plus_n) }+++mkClosureLFInfo :: DynFlags+                -> Id           -- The binder+                -> TopLevelFlag -- True of top level+                -> [NonVoid Id] -- Free vars+                -> UpdateFlag   -- Update flag+                -> [Id]         -- Args+                -> LambdaFormInfo+mkClosureLFInfo dflags bndr top fvs upd_flag args+  | null args =+        mkLFThunk (idType bndr) top (map fromNonVoid fvs) upd_flag+  | otherwise =+        mkLFReEntrant top (map fromNonVoid fvs) args (mkArgDescr dflags args)+++------------------------------------------------------------------------+--              The code for closures+------------------------------------------------------------------------++closureCodeBody :: Bool            -- whether this is a top-level binding+                -> Id              -- the closure's name+                -> ClosureInfo     -- Lots of information about this closure+                -> CostCentreStack -- Optional cost centre attached to closure+                -> [NonVoid Id]    -- incoming args to the closure+                -> Int             -- arity, including void args+                -> CgStgExpr+                -> [(NonVoid Id, ByteOff)] -- the closure's free vars+                -> FCode ()++{- There are two main cases for the code for closures.++* If there are *no arguments*, then the closure is a thunk, and not in+  normal form. So it should set up an update frame (if it is+  shared). NB: Thunks cannot have a primitive type!++* If there is *at least one* argument, then this closure is in+  normal form, so there is no need to set up an update frame.+-}++closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details+  | arity == 0 -- No args i.e. thunk+  = withNewTickyCounterThunk+        (isStaticClosure cl_info)+        (closureUpdReqd cl_info)+        (closureName cl_info) $+    emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $+      \(_, node, _) -> thunkCode cl_info fv_details cc node arity body+   where+     lf_info  = closureLFInfo cl_info+     info_tbl = mkCmmInfo cl_info bndr cc++closureCodeBody top_lvl bndr cl_info cc args arity body fv_details+  = -- Note: args may be [], if all args are Void+    withNewTickyCounterFun+        (closureSingleEntry cl_info)+        (closureName cl_info)+        args $ do {++        ; let+             lf_info  = closureLFInfo cl_info+             info_tbl = mkCmmInfo cl_info bndr cc++        -- Emit the main entry code+        ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $+            \(_offset, node, arg_regs) -> do+                -- Emit slow-entry code (for entering a closure through a PAP)+                { mkSlowEntryCode bndr cl_info arg_regs+                ; dflags <- getDynFlags+                ; let node_points = nodeMustPointToIt dflags lf_info+                      node' = if node_points then Just node else Nothing+                ; loop_header_id <- newBlockId+                -- Extend reader monad with information that+                -- self-recursive tail calls can be optimized into local+                -- jumps. See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr.+                ; withSelfLoop (bndr, loop_header_id, arg_regs) $ do+                {+                -- Main payload+                ; entryHeapCheck cl_info node' arity arg_regs $ do+                { -- emit LDV code when profiling+                  when node_points (ldvEnterClosure cl_info (CmmLocal node))+                -- ticky after heap check to avoid double counting+                ; tickyEnterFun cl_info+                ; enterCostCentreFun cc+                    (CmmMachOp (mo_wordSub dflags)+                         [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]+                         , mkIntExpr dflags (funTag dflags cl_info) ])+                ; fv_bindings <- mapM bind_fv fv_details+                -- Load free vars out of closure *after*+                -- heap check, to reduce live vars over check+                ; when node_points $ load_fvs node lf_info fv_bindings+                ; void $ cgExpr body+                }}}++  }++-- Note [NodeReg clobbered with loopification]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Previously we used to pass nodeReg (aka R1) here. With profiling, upon+-- entering a closure, enterFunCCS was called with R1 passed to it. But since R1+-- may get clobbered inside the body of a closure, and since a self-recursive+-- tail call does not restore R1, a subsequent call to enterFunCCS received a+-- possibly bogus value from R1. The solution is to not pass nodeReg (aka R1) to+-- enterFunCCS. Instead, we pass node, the callee-saved temporary that stores+-- the original value of R1. This way R1 may get modified but loopification will+-- not care.++-- A function closure pointer may be tagged, so we+-- must take it into account when accessing the free variables.+bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)+bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }++load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()+load_fvs node lf_info = mapM_ (\ (reg, off) ->+   do dflags <- getDynFlags+      let tag = lfDynTag dflags lf_info+      emit $ mkTaggedObjectLoad dflags reg node off tag)++-----------------------------------------+-- The "slow entry" code for a function.  This entry point takes its+-- arguments on the stack.  It loads the arguments into registers+-- according to the calling convention, and jumps to the function's+-- normal entry point.  The function's closure is assumed to be in+-- R1/node.+--+-- The slow entry point is used for unknown calls: eg. stg_PAP_entry++mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode ()+-- If this function doesn't have a specialised ArgDescr, we need+-- to generate the function's arg bitmap and slow-entry code.+-- Here, we emit the slow-entry code.+mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'+  | Just (_, ArgGen _) <- closureFunInfo cl_info+  = do dflags <- getDynFlags+       let node = idToReg dflags (NonVoid bndr)+           slow_lbl = closureSlowEntryLabel  cl_info+           fast_lbl = closureLocalEntryLabel dflags cl_info+           -- mkDirectJump does not clobber `Node' containing function closure+           jump = mkJump dflags NativeNodeCall+                                (mkLblExpr fast_lbl)+                                (map (CmmReg . CmmLocal) (node : arg_regs))+                                (initUpdFrameOff dflags)+       tscope <- getTickScope+       emitProcWithConvention Slow Nothing slow_lbl+         (node : arg_regs) (jump, tscope)+  | otherwise = return ()++-----------------------------------------+thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack+          -> LocalReg -> Int -> CgStgExpr -> FCode ()+thunkCode cl_info fv_details _cc node arity body+  = do { dflags <- getDynFlags+       ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info)+             node'       = if node_points then Just node else Nothing+        ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling++        -- Heap overflow check+        ; entryHeapCheck cl_info node' arity [] $ do+        { -- Overwrite with black hole if necessary+          -- but *after* the heap-overflow check+        ; tickyEnterThunk cl_info+        ; when (blackHoleOnEntry cl_info && node_points)+                (blackHoleIt node)++          -- Push update frame+        ; setupUpdate cl_info node $+            -- We only enter cc after setting up update so+            -- that cc of enclosing scope will be recorded+            -- in update frame CAF/DICT functions will be+            -- subsumed by this enclosing cc+            do { enterCostCentreThunk (CmmReg nodeReg)+               ; let lf_info = closureLFInfo cl_info+               ; fv_bindings <- mapM bind_fv fv_details+               ; load_fvs node lf_info fv_bindings+               ; void $ cgExpr body }}}+++------------------------------------------------------------------------+--              Update and black-hole wrappers+------------------------------------------------------------------------++blackHoleIt :: LocalReg -> FCode ()+-- Only called for closures with no args+-- Node points to the closure+blackHoleIt node_reg+  = emitBlackHoleCode (CmmReg (CmmLocal node_reg))++emitBlackHoleCode :: CmmExpr -> FCode ()+emitBlackHoleCode node = do+  dflags <- getDynFlags++  -- Eager blackholing is normally disabled, but can be turned on with+  -- -feager-blackholing.  When it is on, we replace the info pointer+  -- of the thunk with stg_EAGER_BLACKHOLE_info on entry.++  -- If we wanted to do eager blackholing with slop filling, we'd need+  -- to do it at the *end* of a basic block, otherwise we overwrite+  -- the free variables in the thunk that we still need.  We have a+  -- patch for this from Andy Cheadle, but not incorporated yet. --SDM+  -- [6/2004]+  --+  -- Previously, eager blackholing was enabled when ticky-ticky was+  -- on. But it didn't work, and it wasn't strictly necessary to bring+  -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is+  -- unconditionally disabled. -- krc 1/2007++  -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,+  -- because emitBlackHoleCode is called from CmmParse.++  let  eager_blackholing =  not (gopt Opt_SccProfilingOn dflags)+                         && gopt Opt_EagerBlackHoling dflags+             -- Profiling needs slop filling (to support LDV+             -- profiling), so currently eager blackholing doesn't+             -- work with profiling.++  when eager_blackholing $ do+    whenUpdRemSetEnabled dflags $ emitUpdRemSetPushThunk node+    emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) currentTSOExpr+    -- See Note [Heap memory barriers] in SMP.h.+    emitPrimCall [] MO_WriteBarrier []+    emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))++setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()+        -- Nota Bene: this function does not change Node (even if it's a CAF),+        -- so that the cost centre in the original closure can still be+        -- extracted by a subsequent enterCostCentre+setupUpdate closure_info node body+  | not (lfUpdatable (closureLFInfo closure_info))+  = body++  | not (isStaticClosure closure_info)+  = if not (closureUpdReqd closure_info)+      then do tickyUpdateFrameOmitted; body+      else do+          tickyPushUpdateFrame+          dflags <- getDynFlags+          let+              bh = blackHoleOnEntry closure_info &&+                   not (gopt Opt_SccProfilingOn dflags) &&+                   gopt Opt_EagerBlackHoling dflags++              lbl | bh        = mkBHUpdInfoLabel+                  | otherwise = mkUpdInfoLabel++          pushUpdateFrame lbl (CmmReg (CmmLocal node)) body++  | otherwise   -- A static closure+  = do  { tickyUpdateBhCaf closure_info++        ; if closureUpdReqd closure_info+          then do       -- Blackhole the (updatable) CAF:+                { upd_closure <- link_caf node+                ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body }+          else do {tickyUpdateFrameOmitted; body}+    }++-----------------------------------------------------------------------------+-- Setting up update frames++-- Push the update frame on the stack in the Entry area,+-- leaving room for the return address that is already+-- at the old end of the area.+--+pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode ()+pushUpdateFrame lbl updatee body+  = do+       updfr  <- getUpdFrameOff+       dflags <- getDynFlags+       let+           hdr         = fixedHdrSize dflags+           frame       = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags+       --+       emitUpdateFrame dflags (CmmStackSlot Old frame) lbl updatee+       withUpdFrameOff frame body++emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode ()+emitUpdateFrame dflags frame lbl updatee = do+  let+           hdr         = fixedHdrSize dflags+           off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags+  --+  emitStore frame (mkLblExpr lbl)+  emitStore (cmmOffset dflags frame off_updatee) updatee+  initUpdFrameProf frame++-----------------------------------------------------------------------------+-- Entering a CAF+--+-- See Note [CAF management] in rts/sm/Storage.c++link_caf :: LocalReg           -- pointer to the closure+         -> FCode CmmExpr      -- Returns amode for closure to be updated+-- This function returns the address of the black hole, so it can be+-- updated with the new value when available.+link_caf node = do+  { dflags <- getDynFlags+        -- Call the RTS function newCAF, returning the newly-allocated+        -- blackhole indirection closure+  ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing+                                    ForeignLabelInExternalPackage IsFunction+  ; bh <- newTemp (bWord dflags)+  ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl+      [ (baseExpr,  AddrHint),+        (CmmReg (CmmLocal node), AddrHint) ]+      False++  -- see Note [atomic CAF entry] in rts/sm/Storage.c+  ; updfr  <- getUpdFrameOff+  ; let target = entryCode dflags (closureInfoPtr dflags (CmmReg (CmmLocal node)))+  ; emit =<< mkCmmIfThen+      (cmmEqWord dflags (CmmReg (CmmLocal bh)) (zeroExpr dflags))+        -- re-enter the CAF+       (mkJump dflags NativeNodeCall target [] updfr)++  ; return (CmmReg (CmmLocal bh)) }++------------------------------------------------------------------------+--              Profiling+------------------------------------------------------------------------++-- For "global" data constructors the description is simply occurrence+-- name of the data constructor itself.  Otherwise it is determined by+-- @closureDescription@ from the let binding information.++closureDescription :: DynFlags+           -> Module            -- Module+                   -> Name              -- Id of closure binding+                   -> String+        -- Not called for StgRhsCon which have global info tables built in+        -- CgConTbls.hs with a description generated from the data constructor+closureDescription dflags mod_name name+  = showSDocDump dflags (char '<' <>+                    (if isExternalName name+                      then ppr name -- ppr will include the module name prefix+                      else pprModule mod_name <> char '.' <> ppr name) <>+                    char '>')+   -- showSDocDump, because we want to see the unique on the Name.
+ compiler/GHC/StgToCmm/Bind.hs-boot view
@@ -0,0 +1,6 @@+module GHC.StgToCmm.Bind where++import GHC.StgToCmm.Monad( FCode )+import StgSyn( CgStgBinding )++cgBind :: CgStgBinding -> FCode ()
+ compiler/GHC/StgToCmm/CgUtils.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE GADTs #-}++-----------------------------------------------------------------------------+--+-- Code generator utilities; mostly monadic+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.CgUtils (+        fixStgRegisters,+        baseRegOffset,+        get_Regtable_addr_from_offset,+        regTableOffset,+        get_GlobalReg_addr,+  ) where++import GhcPrelude++import GHC.Platform.Regs+import Cmm+import Hoopl.Block+import Hoopl.Graph+import CmmUtils+import CLabel+import DynFlags+import Outputable++-- -----------------------------------------------------------------------------+-- Information about global registers++baseRegOffset :: DynFlags -> GlobalReg -> Int++baseRegOffset dflags (VanillaReg 1 _)    = oFFSET_StgRegTable_rR1 dflags+baseRegOffset dflags (VanillaReg 2 _)    = oFFSET_StgRegTable_rR2 dflags+baseRegOffset dflags (VanillaReg 3 _)    = oFFSET_StgRegTable_rR3 dflags+baseRegOffset dflags (VanillaReg 4 _)    = oFFSET_StgRegTable_rR4 dflags+baseRegOffset dflags (VanillaReg 5 _)    = oFFSET_StgRegTable_rR5 dflags+baseRegOffset dflags (VanillaReg 6 _)    = oFFSET_StgRegTable_rR6 dflags+baseRegOffset dflags (VanillaReg 7 _)    = oFFSET_StgRegTable_rR7 dflags+baseRegOffset dflags (VanillaReg 8 _)    = oFFSET_StgRegTable_rR8 dflags+baseRegOffset dflags (VanillaReg 9 _)    = oFFSET_StgRegTable_rR9 dflags+baseRegOffset dflags (VanillaReg 10 _)   = oFFSET_StgRegTable_rR10 dflags+baseRegOffset _      (VanillaReg n _)    = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")")+baseRegOffset dflags (FloatReg  1)       = oFFSET_StgRegTable_rF1 dflags+baseRegOffset dflags (FloatReg  2)       = oFFSET_StgRegTable_rF2 dflags+baseRegOffset dflags (FloatReg  3)       = oFFSET_StgRegTable_rF3 dflags+baseRegOffset dflags (FloatReg  4)       = oFFSET_StgRegTable_rF4 dflags+baseRegOffset dflags (FloatReg  5)       = oFFSET_StgRegTable_rF5 dflags+baseRegOffset dflags (FloatReg  6)       = oFFSET_StgRegTable_rF6 dflags+baseRegOffset _      (FloatReg  n)       = panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")")+baseRegOffset dflags (DoubleReg 1)       = oFFSET_StgRegTable_rD1 dflags+baseRegOffset dflags (DoubleReg 2)       = oFFSET_StgRegTable_rD2 dflags+baseRegOffset dflags (DoubleReg 3)       = oFFSET_StgRegTable_rD3 dflags+baseRegOffset dflags (DoubleReg 4)       = oFFSET_StgRegTable_rD4 dflags+baseRegOffset dflags (DoubleReg 5)       = oFFSET_StgRegTable_rD5 dflags+baseRegOffset dflags (DoubleReg 6)       = oFFSET_StgRegTable_rD6 dflags+baseRegOffset _      (DoubleReg n)       = panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")")+baseRegOffset dflags (XmmReg 1)          = oFFSET_StgRegTable_rXMM1 dflags+baseRegOffset dflags (XmmReg 2)          = oFFSET_StgRegTable_rXMM2 dflags+baseRegOffset dflags (XmmReg 3)          = oFFSET_StgRegTable_rXMM3 dflags+baseRegOffset dflags (XmmReg 4)          = oFFSET_StgRegTable_rXMM4 dflags+baseRegOffset dflags (XmmReg 5)          = oFFSET_StgRegTable_rXMM5 dflags+baseRegOffset dflags (XmmReg 6)          = oFFSET_StgRegTable_rXMM6 dflags+baseRegOffset _      (XmmReg n)          = panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")")+baseRegOffset dflags (YmmReg 1)          = oFFSET_StgRegTable_rYMM1 dflags+baseRegOffset dflags (YmmReg 2)          = oFFSET_StgRegTable_rYMM2 dflags+baseRegOffset dflags (YmmReg 3)          = oFFSET_StgRegTable_rYMM3 dflags+baseRegOffset dflags (YmmReg 4)          = oFFSET_StgRegTable_rYMM4 dflags+baseRegOffset dflags (YmmReg 5)          = oFFSET_StgRegTable_rYMM5 dflags+baseRegOffset dflags (YmmReg 6)          = oFFSET_StgRegTable_rYMM6 dflags+baseRegOffset _      (YmmReg n)          = panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")")+baseRegOffset dflags (ZmmReg 1)          = oFFSET_StgRegTable_rZMM1 dflags+baseRegOffset dflags (ZmmReg 2)          = oFFSET_StgRegTable_rZMM2 dflags+baseRegOffset dflags (ZmmReg 3)          = oFFSET_StgRegTable_rZMM3 dflags+baseRegOffset dflags (ZmmReg 4)          = oFFSET_StgRegTable_rZMM4 dflags+baseRegOffset dflags (ZmmReg 5)          = oFFSET_StgRegTable_rZMM5 dflags+baseRegOffset dflags (ZmmReg 6)          = oFFSET_StgRegTable_rZMM6 dflags+baseRegOffset _      (ZmmReg n)          = panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")")+baseRegOffset dflags Sp                  = oFFSET_StgRegTable_rSp dflags+baseRegOffset dflags SpLim               = oFFSET_StgRegTable_rSpLim dflags+baseRegOffset dflags (LongReg 1)         = oFFSET_StgRegTable_rL1 dflags+baseRegOffset _      (LongReg n)         = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")")+baseRegOffset dflags Hp                  = oFFSET_StgRegTable_rHp dflags+baseRegOffset dflags HpLim               = oFFSET_StgRegTable_rHpLim dflags+baseRegOffset dflags CCCS                = oFFSET_StgRegTable_rCCCS dflags+baseRegOffset dflags CurrentTSO          = oFFSET_StgRegTable_rCurrentTSO dflags+baseRegOffset dflags CurrentNursery      = oFFSET_StgRegTable_rCurrentNursery dflags+baseRegOffset dflags HpAlloc             = oFFSET_StgRegTable_rHpAlloc dflags+baseRegOffset dflags EagerBlackholeInfo  = oFFSET_stgEagerBlackholeInfo dflags+baseRegOffset dflags GCEnter1            = oFFSET_stgGCEnter1 dflags+baseRegOffset dflags GCFun               = oFFSET_stgGCFun dflags+baseRegOffset _      BaseReg             = panic "CgUtils.baseRegOffset:BaseReg"+baseRegOffset _      PicBaseReg          = panic "CgUtils.baseRegOffset:PicBaseReg"+baseRegOffset _      MachSp              = panic "CgUtils.baseRegOffset:MachSp"+baseRegOffset _      UnwindReturnReg     = panic "CgUtils.baseRegOffset:UnwindReturnReg"+++-- -----------------------------------------------------------------------------+--+-- STG/Cmm GlobalReg+--+-- -----------------------------------------------------------------------------++-- | We map STG registers onto appropriate CmmExprs.  Either they map+-- to real machine registers or stored as offsets from BaseReg.  Given+-- a GlobalReg, get_GlobalReg_addr always produces the+-- register table address for it.+get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr+get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0+get_GlobalReg_addr dflags mid+    = get_Regtable_addr_from_offset dflags (baseRegOffset dflags mid)++-- Calculate a literal representing an offset into the register table.+-- Used when we don't have an actual BaseReg to offset from.+regTableOffset :: DynFlags -> Int -> CmmExpr+regTableOffset dflags n =+  CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))++get_Regtable_addr_from_offset :: DynFlags -> Int -> CmmExpr+get_Regtable_addr_from_offset dflags offset =+    if haveRegBase (targetPlatform dflags)+    then CmmRegOff baseReg offset+    else regTableOffset dflags offset++-- | Fixup global registers so that they assign to locations within the+-- RegTable if they aren't pinned for the current target.+fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl+fixStgRegisters _ top@(CmmData _ _) = top++fixStgRegisters dflags (CmmProc info lbl live graph) =+  let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock dflags)) graph+  in CmmProc info lbl live graph'++fixStgRegBlock :: DynFlags -> Block CmmNode e x -> Block CmmNode e x+fixStgRegBlock dflags block = mapBlock (fixStgRegStmt dflags) block++fixStgRegStmt :: DynFlags -> CmmNode e x -> CmmNode e x+fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt+  where+    platform = targetPlatform dflags++    fixAssign stmt =+      case stmt of+        CmmAssign (CmmGlobal reg) src+          -- MachSp isn't an STG register; it's merely here for tracking unwind+          -- information+          | reg == MachSp -> stmt+          | otherwise ->+            let baseAddr = get_GlobalReg_addr dflags reg+            in case reg `elem` activeStgRegs (targetPlatform dflags) of+                True  -> CmmAssign (CmmGlobal reg) src+                False -> CmmStore baseAddr src+        other_stmt -> other_stmt++    fixExpr expr = case expr of+        -- MachSp isn't an STG; it's merely here for tracking unwind information+        CmmReg (CmmGlobal MachSp) -> expr+        CmmReg (CmmGlobal reg) ->+            -- Replace register leaves with appropriate StixTrees for+            -- the given target.  MagicIds which map to a reg on this+            -- arch are left unchanged.  For the rest, BaseReg is taken+            -- to mean the address of the reg table in MainCapability,+            -- and for all others we generate an indirection to its+            -- location in the register table.+            case reg `elem` activeStgRegs platform of+                True  -> expr+                False ->+                    let baseAddr = get_GlobalReg_addr dflags reg+                    in case reg of+                        BaseReg -> baseAddr+                        _other  -> CmmLoad baseAddr (globalRegType dflags reg)++        CmmRegOff (CmmGlobal reg) offset ->+            -- RegOf leaves are just a shorthand form. If the reg maps+            -- to a real reg, we keep the shorthand, otherwise, we just+            -- expand it and defer to the above code.+            case reg `elem` activeStgRegs platform of+                True  -> expr+                False -> CmmMachOp (MO_Add (wordWidth dflags)) [+                                    fixExpr (CmmReg (CmmGlobal reg)),+                                    CmmLit (CmmInt (fromIntegral offset)+                                                   (wordWidth dflags))]++        other_expr -> other_expr
+ compiler/GHC/StgToCmm/Closure.hs view
@@ -0,0 +1,1005 @@+{-# LANGUAGE CPP, RecordWildCards #-}++-----------------------------------------------------------------------------+--+-- Stg to C-- code generation:+--+-- The types   LambdaFormInfo+--             ClosureInfo+--+-- Nothing monadic in here!+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Closure (+        DynTag,  tagForCon, isSmallFamily,++        idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps,+        argPrimRep,++        NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs,+        assertNonVoidIds, assertNonVoidStgArgs,++        -- * LambdaFormInfo+        LambdaFormInfo,         -- Abstract+        StandardFormInfo,        -- ...ditto...+        mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,+        mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,+        mkLFStringLit,+        lfDynTag,+        isLFThunk, isLFReEntrant, lfUpdatable,++        -- * Used by other modules+        CgLoc(..), SelfLoopInfo, CallMethod(..),+        nodeMustPointToIt, isKnownFun, funTag, tagForArity, getCallMethod,++        -- * ClosureInfo+        ClosureInfo,+        mkClosureInfo,+        mkCmmInfo,++        -- ** Inspection+        closureLFInfo, closureName,++        -- ** Labels+        -- These just need the info table label+        closureInfoLabel, staticClosureLabel,+        closureSlowEntryLabel, closureLocalEntryLabel,++        -- ** Predicates+        -- These are really just functions on LambdaFormInfo+        closureUpdReqd, closureSingleEntry,+        closureReEntrant, closureFunInfo,+        isToplevClosure,++        blackHoleOnEntry,  -- Needs LambdaFormInfo and SMRep+        isStaticClosure,   -- Needs SMPre++        -- * InfoTables+        mkDataConInfoTable,+        cafBlackHoleInfoTable,+        indStaticInfoTable,+        staticClosureNeedsLink,+    ) where++#include "HsVersions.h"++import GhcPrelude++import StgSyn+import SMRep+import Cmm+import PprCmmExpr() -- For Outputable instances++import CostCentre+import BlockId+import CLabel+import Id+import IdInfo+import DataCon+import Name+import Type+import TyCoRep+import TcType+import TyCon+import RepType+import BasicTypes+import Outputable+import DynFlags+import Util++import Data.Coerce (coerce)+import qualified Data.ByteString.Char8 as BS8++-----------------------------------------------------------------------------+--                Data types and synonyms+-----------------------------------------------------------------------------++-- These data types are mostly used by other modules, especially+-- GHC.StgToCmm.Monad, but we define them here because some functions in this+-- module need to have access to them as well++data CgLoc+  = CmmLoc CmmExpr      -- A stable CmmExpr; that is, one not mentioning+                        -- Hp, so that it remains valid across calls++  | LneLoc BlockId [LocalReg]             -- A join point+        -- A join point (= let-no-escape) should only+        -- be tail-called, and in a saturated way.+        -- To tail-call it, assign to these locals,+        -- and branch to the block id++instance Outputable CgLoc where+  ppr (CmmLoc e)    = text "cmm" <+> ppr e+  ppr (LneLoc b rs) = text "lne" <+> ppr b <+> ppr rs++type SelfLoopInfo = (Id, BlockId, [LocalReg])++-- used by ticky profiling+isKnownFun :: LambdaFormInfo -> Bool+isKnownFun LFReEntrant{} = True+isKnownFun LFLetNoEscape = True+isKnownFun _             = False+++-------------------------------------+--        Non-void types+-------------------------------------+-- We frequently need the invariant that an Id or a an argument+-- is of a non-void type. This type is a witness to the invariant.++newtype NonVoid a = NonVoid a+  deriving (Eq, Show)++fromNonVoid :: NonVoid a -> a+fromNonVoid (NonVoid a) = a++instance (Outputable a) => Outputable (NonVoid a) where+  ppr (NonVoid a) = ppr a++nonVoidIds :: [Id] -> [NonVoid Id]+nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidTy (idType id))]++-- | Used in places where some invariant ensures that all these Ids are+-- non-void; e.g. constructor field binders in case expressions.+-- See Note [Post-unarisation invariants] in UnariseStg.+assertNonVoidIds :: [Id] -> [NonVoid Id]+assertNonVoidIds ids = ASSERT(not (any (isVoidTy . idType) ids))+                       coerce ids++nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]+nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isVoidTy (stgArgType arg))]++-- | Used in places where some invariant ensures that all these arguments are+-- non-void; e.g. constructor arguments.+-- See Note [Post-unarisation invariants] in UnariseStg.+assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]+assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args))+                            coerce args+++-----------------------------------------------------------------------------+--                Representations+-----------------------------------------------------------------------------++-- Why are these here?++-- | Assumes that there is precisely one 'PrimRep' of the type. This assumption+-- holds after unarise.+-- See Note [Post-unarisation invariants]+idPrimRep :: Id -> PrimRep+idPrimRep id = typePrimRep1 (idType id)+    -- See also Note [VoidRep] in RepType++-- | Assumes that Ids have one PrimRep, which holds after unarisation.+-- See Note [Post-unarisation invariants]+addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)]+addIdReps = map (\id -> let id' = fromNonVoid id+                         in NonVoid (idPrimRep id', id'))++-- | Assumes that arguments have one PrimRep, which holds after unarisation.+-- See Note [Post-unarisation invariants]+addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]+addArgReps = map (\arg -> let arg' = fromNonVoid arg+                           in NonVoid (argPrimRep arg', arg'))++-- | Assumes that the argument has one PrimRep, which holds after unarisation.+-- See Note [Post-unarisation invariants]+argPrimRep :: StgArg -> PrimRep+argPrimRep arg = typePrimRep1 (stgArgType arg)+++-----------------------------------------------------------------------------+--                LambdaFormInfo+-----------------------------------------------------------------------------++-- Information about an identifier, from the code generator's point of+-- view.  Every identifier is bound to a LambdaFormInfo in the+-- environment, which gives the code generator enough info to be able to+-- tail call or return that identifier.++data LambdaFormInfo+  = LFReEntrant         -- Reentrant closure (a function)+        TopLevelFlag    -- True if top level+        OneShotInfo+        !RepArity       -- Arity. Invariant: always > 0+        !Bool           -- True <=> no fvs+        ArgDescr        -- Argument descriptor (should really be in ClosureInfo)++  | LFThunk             -- Thunk (zero arity)+        TopLevelFlag+        !Bool           -- True <=> no free vars+        !Bool           -- True <=> updatable (i.e., *not* single-entry)+        StandardFormInfo+        !Bool           -- True <=> *might* be a function type++  | LFCon               -- A saturated constructor application+        DataCon         -- The constructor++  | LFUnknown           -- Used for function arguments and imported things.+                        -- We know nothing about this closure.+                        -- Treat like updatable "LFThunk"...+                        -- Imported things which we *do* know something about use+                        -- one of the other LF constructors (eg LFReEntrant for+                        -- known functions)+        !Bool           -- True <=> *might* be a function type+                        --      The False case is good when we want to enter it,+                        --        because then we know the entry code will do+                        --        For a function, the entry code is the fast entry point++  | LFUnlifted          -- A value of unboxed type;+                        -- always a value, needs evaluation++  | LFLetNoEscape       -- See LetNoEscape module for precise description+++-------------------------+-- StandardFormInfo tells whether this thunk has one of+-- a small number of standard forms++data StandardFormInfo+  = NonStandardThunk+        -- The usual case: not of the standard forms++  | SelectorThunk+        -- A SelectorThunk is of form+        --      case x of+        --           con a1,..,an -> ak+        -- and the constructor is from a single-constr type.+       WordOff          -- 0-origin offset of ak within the "goods" of+                        -- constructor (Recall that the a1,...,an may be laid+                        -- out in the heap in a non-obvious order.)++  | ApThunk+        -- An ApThunk is of form+        --        x1 ... xn+        -- The code for the thunk just pushes x2..xn on the stack and enters x1.+        -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled+        -- in the RTS to save space.+        RepArity                -- Arity, n+++------------------------------------------------------+--                Building LambdaFormInfo+------------------------------------------------------++mkLFArgument :: Id -> LambdaFormInfo+mkLFArgument id+  | isUnliftedType ty      = LFUnlifted+  | might_be_a_function ty = LFUnknown True+  | otherwise              = LFUnknown False+  where+    ty = idType id++-------------+mkLFLetNoEscape :: LambdaFormInfo+mkLFLetNoEscape = LFLetNoEscape++-------------+mkLFReEntrant :: TopLevelFlag    -- True of top level+              -> [Id]            -- Free vars+              -> [Id]            -- Args+              -> ArgDescr        -- Argument descriptor+              -> LambdaFormInfo++mkLFReEntrant _ _ [] _+  = pprPanic "mkLFReEntrant" empty+mkLFReEntrant top fvs args arg_descr+  = LFReEntrant top os_info (length args) (null fvs) arg_descr+  where os_info = idOneShotInfo (head args)++-------------+mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo+mkLFThunk thunk_ty top fvs upd_flag+  = ASSERT( not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty) )+    LFThunk top (null fvs)+            (isUpdatable upd_flag)+            NonStandardThunk+            (might_be_a_function thunk_ty)++--------------+might_be_a_function :: Type -> Bool+-- Return False only if we are *sure* it's a data type+-- Look through newtypes etc as much as poss+might_be_a_function ty+  | [LiftedRep] <- typePrimRep ty+  , Just tc <- tyConAppTyCon_maybe (unwrapType ty)+  , isDataTyCon tc+  = False+  | otherwise+  = True++-------------+mkConLFInfo :: DataCon -> LambdaFormInfo+mkConLFInfo con = LFCon con++-------------+mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo+mkSelectorLFInfo id offset updatable+  = LFThunk NotTopLevel False updatable (SelectorThunk offset)+        (might_be_a_function (idType id))++-------------+mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo+mkApLFInfo id upd_flag arity+  = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)+        (might_be_a_function (idType id))++-------------+mkLFImported :: Id -> LambdaFormInfo+mkLFImported id+  | Just con <- isDataConWorkId_maybe id+  , isNullaryRepDataCon con+  = LFCon con   -- An imported nullary constructor+                -- We assume that the constructor is evaluated so that+                -- the id really does point directly to the constructor++  | arity > 0+  = LFReEntrant TopLevel noOneShotInfo arity True (panic "arg_descr")++  | otherwise+  = mkLFArgument id -- Not sure of exact arity+  where+    arity = idFunRepArity id++-------------+mkLFStringLit :: LambdaFormInfo+mkLFStringLit = LFUnlifted++-----------------------------------------------------+--                Dynamic pointer tagging+-----------------------------------------------------++type DynTag = Int       -- The tag on a *pointer*+                        -- (from the dynamic-tagging paper)++-- Note [Data constructor dynamic tags]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- The family size of a data type (the number of constructors+-- or the arity of a function) can be either:+--    * small, if the family size < 2**tag_bits+--    * big, otherwise.+--+-- Small families can have the constructor tag in the tag bits.+-- 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 = min (dataConTag con) (mAX_PTR_TAG dflags)+-- NB: 1-indexed++tagForArity :: DynFlags -> RepArity -> DynTag+tagForArity dflags arity+ | isSmallFamily dflags arity = arity+ | otherwise                  = 0++lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag+-- Return the tag in the low order bits of a variable bound+-- to this LambdaForm+lfDynTag dflags (LFCon con)                 = tagForCon dflags con+lfDynTag dflags (LFReEntrant _ _ arity _ _) = tagForArity dflags arity+lfDynTag _      _other                      = 0+++-----------------------------------------------------------------------------+--                Observing LambdaFormInfo+-----------------------------------------------------------------------------++------------+isLFThunk :: LambdaFormInfo -> Bool+isLFThunk (LFThunk {})  = True+isLFThunk _ = False++isLFReEntrant :: LambdaFormInfo -> Bool+isLFReEntrant (LFReEntrant {}) = True+isLFReEntrant _                = False++-----------------------------------------------------------------------------+--                Choosing SM reps+-----------------------------------------------------------------------------++lfClosureType :: LambdaFormInfo -> ClosureTypeInfo+lfClosureType (LFReEntrant _ _ arity _ argd) = Fun arity argd+lfClosureType (LFCon con)                    = Constr (dataConTagZ con)+                                                      (dataConIdentity con)+lfClosureType (LFThunk _ _ _ is_sel _)       = thunkClosureType is_sel+lfClosureType _                              = panic "lfClosureType"++thunkClosureType :: StandardFormInfo -> ClosureTypeInfo+thunkClosureType (SelectorThunk off) = ThunkSelector off+thunkClosureType _                   = Thunk++-- We *do* get non-updatable top-level thunks sometimes.  eg. f = g+-- gets compiled to a jump to g (if g has non-zero arity), instead of+-- messing around with update frames and PAPs.  We set the closure type+-- to FUN_STATIC in this case.++-----------------------------------------------------------------------------+--                nodeMustPointToIt+-----------------------------------------------------------------------------++nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool+-- If nodeMustPointToIt is true, then the entry convention for+-- this closure has R1 (the "Node" register) pointing to the+-- closure itself --- the "self" argument++nodeMustPointToIt _ (LFReEntrant top _ _ no_fvs _)+  =  not no_fvs          -- Certainly if it has fvs we need to point to it+  || isNotTopLevel top   -- See Note [GC recovery]+        -- For lex_profiling we also access the cost centre for a+        -- non-inherited (i.e. non-top-level) function.+        -- The isNotTopLevel test above ensures this is ok.++nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _)+  =  not no_fvs            -- Self parameter+  || isNotTopLevel top     -- Note [GC recovery]+  || updatable             -- Need to push update frame+  || gopt Opt_SccProfilingOn dflags+          -- For the non-updatable (single-entry case):+          --+          -- True if has fvs (in which case we need access to them, and we+          --                    should black-hole it)+          -- or profiling (in which case we need to recover the cost centre+          --                 from inside it)  ToDo: do we need this even for+          --                                    top-level thunks? If not,+          --                                    isNotTopLevel subsumes this++nodeMustPointToIt _ (LFThunk {})        -- Node must point to a standard-form thunk+  = True++nodeMustPointToIt _ (LFCon _) = True++        -- Strictly speaking, the above two don't need Node to point+        -- to it if the arity = 0.  But this is a *really* unlikely+        -- situation.  If we know it's nil (say) and we are entering+        -- it. Eg: let x = [] in x then we will certainly have inlined+        -- x, since nil is a simple atom.  So we gain little by not+        -- having Node point to known zero-arity things.  On the other+        -- hand, we do lose something; Patrick's code for figuring out+        -- when something has been updated but not entered relies on+        -- having Node point to the result of an update.  SLPJ+        -- 27/11/92.++nodeMustPointToIt _ (LFUnknown _)   = True+nodeMustPointToIt _ LFUnlifted      = False+nodeMustPointToIt _ LFLetNoEscape   = False++{- Note [GC recovery]+~~~~~~~~~~~~~~~~~~~~~+If we a have a local let-binding (function or thunk)+   let f = <body> in ...+AND <body> allocates, then the heap-overflow check needs to know how+to re-start the evaluation.  It uses the "self" pointer to do this.+So even if there are no free variables in <body>, we still make+nodeMustPointToIt be True for non-top-level bindings.++Why do any such bindings exist?  After all, let-floating should have+floated them out.  Well, a clever optimiser might leave one there to+avoid a space leak, deliberately recomputing a thunk.  Also (and this+really does happen occasionally) let-floating may make a function f smaller+so it can be inlined, so now (f True) may generate a local no-fv closure.+This actually happened during bootstrapping GHC itself, with f=mkRdrFunBind+in TcGenDeriv.) -}++-----------------------------------------------------------------------------+--                getCallMethod+-----------------------------------------------------------------------------++{- The entry conventions depend on the type of closure being entered,+whether or not it has free variables, and whether we're running+sequentially or in parallel.++Closure                           Node   Argument   Enter+Characteristics              Par   Req'd  Passing    Via+---------------------------------------------------------------------------+Unknown                     & no  & yes & stack     & node+Known fun (>1 arg), no fvs  & no  & no  & registers & fast entry (enough args)+                                                    & slow entry (otherwise)+Known fun (>1 arg), fvs     & no  & yes & registers & fast entry (enough args)+0 arg, no fvs \r,\s         & no  & no  & n/a       & direct entry+0 arg, no fvs \u            & no  & yes & n/a       & node+0 arg, fvs \r,\s,selector   & no  & yes & n/a       & node+0 arg, fvs \r,\s            & no  & yes & n/a       & direct entry+0 arg, fvs \u               & no  & yes & n/a       & node+Unknown                     & yes & yes & stack     & node+Known fun (>1 arg), no fvs  & yes & no  & registers & fast entry (enough args)+                                                    & slow entry (otherwise)+Known fun (>1 arg), fvs     & yes & yes & registers & node+0 arg, fvs \r,\s,selector   & yes & yes & n/a       & node+0 arg, no fvs \r,\s         & yes & no  & n/a       & direct entry+0 arg, no fvs \u            & yes & yes & n/a       & node+0 arg, fvs \r,\s            & yes & yes & n/a       & node+0 arg, fvs \u               & yes & yes & n/a       & node++When black-holing, single-entry closures could also be entered via node+(rather than directly) to catch double-entry. -}++data CallMethod+  = EnterIt             -- No args, not a function++  | JumpToIt BlockId [LocalReg] -- A join point or a header of a local loop++  | ReturnIt            -- It's a value (function, unboxed value,+                        -- or constructor), so just return it.++  | SlowCall                -- Unknown fun, or known fun with+                        -- too few args.++  | DirectEntry         -- Jump directly, with args in regs+        CLabel          --   The code label+        RepArity        --   Its arity++getCallMethod :: DynFlags+              -> Name           -- Function being applied+              -> Id             -- Function Id used to chech if it can refer to+                                -- CAF's and whether the function is tail-calling+                                -- itself+              -> LambdaFormInfo -- Its info+              -> RepArity       -- Number of available arguments+              -> RepArity       -- Number of them being void arguments+              -> CgLoc          -- Passed in from cgIdApp so that we can+                                -- handle let-no-escape bindings and self-recursive+                                -- tail calls using the same data constructor,+                                -- JumpToIt. This saves us one case branch in+                                -- cgIdApp+              -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call?+              -> CallMethod++getCallMethod dflags _ id _ n_args v_args _cg_loc+              (Just (self_loop_id, block_id, args))+  | gopt Opt_Loopification dflags+  , id == self_loop_id+  , args `lengthIs` (n_args - v_args)+  -- If these patterns match then we know that:+  --   * loopification optimisation is turned on+  --   * function is performing a self-recursive call in a tail position+  --   * number of non-void parameters of the function matches functions arity.+  -- See Note [Self-recursive tail calls] and Note [Void arguments in+  -- self-recursive tail calls] in GHC.StgToCmm.Expr for more details+  = JumpToIt block_id args++getCallMethod dflags name id (LFReEntrant _ _ arity _ _) n_args _v_args _cg_loc+              _self_loop_info+  | n_args == 0 -- No args at all+  && not (gopt Opt_SccProfilingOn dflags)+     -- See Note [Evaluating functions with profiling] in rts/Apply.cmm+  = ASSERT( arity /= 0 ) ReturnIt+  | n_args < arity = SlowCall        -- Not enough args+  | otherwise      = DirectEntry (enterIdLabel dflags name (idCafInfo id)) arity++getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info+  = ASSERT( n_args == 0 ) ReturnIt++getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info+  = ASSERT( n_args == 0 ) ReturnIt+    -- n_args=0 because it'd be ill-typed to apply a saturated+    --          constructor application to anything++getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)+              n_args _v_args _cg_loc _self_loop_info+  | is_fun      -- it *might* be a function, so we must "call" it (which is always safe)+  = SlowCall    -- We cannot just enter it [in eval/apply, the entry code+                -- is the fast-entry code]++  -- Since is_fun is False, we are *definitely* looking at a data value+  | updatable || gopt Opt_Ticky dflags -- to catch double entry+      {- OLD: || opt_SMP+         I decided to remove this, because in SMP mode it doesn't matter+         if we enter the same thunk multiple times, so the optimisation+         of jumping directly to the entry code is still valid.  --SDM+        -}+  = EnterIt++  -- even a non-updatable selector thunk can be updated by the garbage+  -- collector, so we must enter it. (#8817)+  | SelectorThunk{} <- std_form_info+  = EnterIt++    -- We used to have ASSERT( n_args == 0 ), but actually it is+    -- possible for the optimiser to generate+    --   let bot :: Int = error Int "urk"+    --   in (bot `cast` unsafeCoerce Int (Int -> Int)) 3+    -- This happens as a result of the case-of-error transformation+    -- So the right thing to do is just to enter the thing++  | otherwise        -- Jump direct to code for single-entry thunks+  = ASSERT( n_args == 0 )+    DirectEntry (thunkEntryLabel dflags name (idCafInfo id) std_form_info+                updatable) 0++getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info+  = SlowCall -- might be a function++getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info+  = ASSERT2( n_args == 0, ppr name <+> ppr n_args )+    EnterIt -- Not a function++getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs)+              _self_loop_info+  = JumpToIt blk_id lne_regs++getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method"++-----------------------------------------------------------------------------+--              Data types for closure information+-----------------------------------------------------------------------------+++{- ClosureInfo: information about a binding++   We make a ClosureInfo for each let binding (both top level and not),+   but not bindings for data constructors: for those we build a CmmInfoTable+   directly (see mkDataConInfoTable).++   To a first approximation:+       ClosureInfo = (LambdaFormInfo, CmmInfoTable)++   A ClosureInfo has enough information+     a) to construct the info table itself, and build other things+        related to the binding (e.g. slow entry points for a function)+     b) to allocate a closure containing that info pointer (i.e.+           it knows the info table label)+-}++data ClosureInfo+  = ClosureInfo {+        closureName :: !Name,           -- The thing bound to this closure+           -- we don't really need this field: it's only used in generating+           -- code for ticky and profiling, and we could pass the information+           -- around separately, but it doesn't do much harm to keep it here.++        closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon+          -- this tells us about what the closure contains: it's right-hand-side.++          -- the rest is just an unpacked CmmInfoTable.+        closureInfoLabel :: !CLabel,+        closureSMRep     :: !SMRep,          -- representation used by storage mgr+        closureProf      :: !ProfilingInfo+    }++-- | Convert from 'ClosureInfo' to 'CmmInfoTable'.+mkCmmInfo :: ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable+mkCmmInfo ClosureInfo {..} id ccs+  = CmmInfoTable { cit_lbl  = closureInfoLabel+                 , cit_rep  = closureSMRep+                 , cit_prof = closureProf+                 , cit_srt  = Nothing+                 , cit_clo  = if isStaticRep closureSMRep+                                then Just (id,ccs)+                                else Nothing }++--------------------------------------+--        Building ClosureInfos+--------------------------------------++mkClosureInfo :: DynFlags+              -> Bool                -- Is static+              -> Id+              -> LambdaFormInfo+              -> Int -> Int        -- Total and pointer words+              -> String         -- String descriptor+              -> ClosureInfo+mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr+  = ClosureInfo { closureName      = name+                , closureLFInfo    = lf_info+                , closureInfoLabel = info_lbl   -- These three fields are+                , closureSMRep     = sm_rep     -- (almost) an info table+                , closureProf      = prof }     -- (we don't have an SRT yet)+  where+    name       = idName id+    sm_rep     = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)+    prof       = mkProfilingInfo dflags id val_descr+    nonptr_wds = tot_wds - ptr_wds++    info_lbl = mkClosureInfoTableLabel id lf_info++--------------------------------------+--   Other functions over ClosureInfo+--------------------------------------++-- Eager blackholing is normally disabled, but can be turned on with+-- -feager-blackholing.  When it is on, we replace the info pointer of+-- the thunk with stg_EAGER_BLACKHOLE_info on entry.++-- If we wanted to do eager blackholing with slop filling,+-- we'd need to do it at the *end* of a basic block, otherwise+-- we overwrite the free variables in the thunk that we still+-- need.  We have a patch for this from Andy Cheadle, but not+-- incorporated yet. --SDM [6/2004]+--+-- Previously, eager blackholing was enabled when ticky-ticky+-- was on. But it didn't work, and it wasn't strictly necessary+-- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING+-- is unconditionally disabled. -- krc 1/2007+--+-- Static closures are never themselves black-holed.++blackHoleOnEntry :: ClosureInfo -> Bool+blackHoleOnEntry cl_info+  | isStaticRep (closureSMRep cl_info)+  = False        -- Never black-hole a static closure++  | otherwise+  = case closureLFInfo cl_info of+      LFReEntrant {}            -> False+      LFLetNoEscape             -> False+      LFThunk _ _no_fvs upd _ _ -> upd   -- See Note [Black-holing non-updatable thunks]+      _other -> panic "blackHoleOnEntry"++{- Note [Black-holing non-updatable thunks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must not black-hole non-updatable (single-entry) thunks otherwise+we run into issues like #10414. Specifically:++  * There is no reason to black-hole a non-updatable thunk: it should+    not be competed for by multiple threads++  * It could, conceivably, cause a space leak if we don't black-hole+    it, if there was a live but never-followed pointer pointing to it.+    Let's hope that doesn't happen.++  * It is dangerous to black-hole a non-updatable thunk because+     - is not updated (of course)+     - hence, if it is black-holed and another thread tries to evaluate+       it, that thread will block forever+    This actually happened in #10414.  So we do not black-hole+    non-updatable thunks.++  * How could two threads evaluate the same non-updatable (single-entry)+    thunk?  See Reid Barton's example below.++  * Only eager blackholing could possibly black-hole a non-updatable+    thunk, because lazy black-holing only affects thunks with an+    update frame on the stack.++Here is and example due to Reid Barton (#10414):+    x = \u []  concat [[1], []]+with the following definitions,++    concat x = case x of+        []       -> []+        (:) x xs -> (++) x (concat xs)++    (++) xs ys = case xs of+        []         -> ys+        (:) x rest -> (:) x ((++) rest ys)++Where we use the syntax @\u []@ to denote an updatable thunk and @\s []@ to+denote a single-entry (i.e. non-updatable) thunk. After a thread evaluates @x@+to WHNF and calls @(++)@ the heap will contain the following thunks,++    x = 1 : y+    y = \u []  (++) [] z+    z = \s []  concat []++Now that the stage is set, consider the follow evaluations by two racing threads+A and B,++  1. Both threads enter @y@ before either is able to replace it with an+     indirection++  2. Thread A does the case analysis in @(++)@ and consequently enters @z@,+     replacing it with a black-hole++  3. At some later point thread B does the same case analysis and also attempts+     to enter @z@. However, it finds that it has been replaced with a black-hole+     so it blocks.++  4. Thread A eventually finishes evaluating @z@ (to @[]@) and updates @y@+     accordingly. It does *not* update @z@, however, as it is single-entry. This+     leaves Thread B blocked forever on a black-hole which will never be+     updated.++To avoid this sort of condition we never black-hole non-updatable thunks.+-}++isStaticClosure :: ClosureInfo -> Bool+isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)++closureUpdReqd :: ClosureInfo -> Bool+closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info++lfUpdatable :: LambdaFormInfo -> Bool+lfUpdatable (LFThunk _ _ upd _ _)  = upd+lfUpdatable _ = False++closureSingleEntry :: ClosureInfo -> Bool+closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd+closureSingleEntry (ClosureInfo { closureLFInfo = LFReEntrant _ OneShotLam _ _ _}) = True+closureSingleEntry _ = False++closureReEntrant :: ClosureInfo -> Bool+closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant {} }) = True+closureReEntrant _ = False++closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)+closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info++lfFunInfo :: LambdaFormInfo ->  Maybe (RepArity, ArgDescr)+lfFunInfo (LFReEntrant _ _ arity _ arg_desc)  = Just (arity, arg_desc)+lfFunInfo _                                   = Nothing++funTag :: DynFlags -> ClosureInfo -> DynTag+funTag dflags (ClosureInfo { closureLFInfo = lf_info })+    = lfDynTag dflags lf_info++isToplevClosure :: ClosureInfo -> Bool+isToplevClosure (ClosureInfo { closureLFInfo = lf_info })+  = case lf_info of+      LFReEntrant TopLevel _ _ _ _ -> True+      LFThunk TopLevel _ _ _ _     -> True+      _other                       -> False++--------------------------------------+--   Label generation+--------------------------------------++staticClosureLabel :: ClosureInfo -> CLabel+staticClosureLabel = toClosureLbl .  closureInfoLabel++closureSlowEntryLabel :: ClosureInfo -> CLabel+closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel++closureLocalEntryLabel :: DynFlags -> ClosureInfo -> CLabel+closureLocalEntryLabel dflags+  | tablesNextToCode dflags = toInfoLbl  . closureInfoLabel+  | otherwise               = toEntryLbl . closureInfoLabel++mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel+mkClosureInfoTableLabel id lf_info+  = case lf_info of+        LFThunk _ _ upd_flag (SelectorThunk offset) _+                      -> mkSelectorInfoLabel upd_flag offset++        LFThunk _ _ upd_flag (ApThunk arity) _+                      -> mkApInfoTableLabel upd_flag arity++        LFThunk{}     -> std_mk_lbl name cafs+        LFReEntrant{} -> std_mk_lbl name cafs+        _other        -> panic "closureInfoTableLabel"++  where+    name = idName id++    std_mk_lbl | is_local  = mkLocalInfoTableLabel+               | otherwise = mkInfoTableLabel++    cafs     = idCafInfo id+    is_local = isDataConWorkId id+       -- Make the _info pointer for the implicit datacon worker+       -- binding local. The reason we can do this is that importing+       -- code always either uses the _closure or _con_info. By the+       -- invariants in CorePrep anything else gets eta expanded.+++thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel+-- thunkEntryLabel is a local help function, not exported.  It's used from+-- getCallMethod.+thunkEntryLabel dflags _thunk_id _ (ApThunk arity) upd_flag+  = enterApLabel dflags upd_flag arity+thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag+  = enterSelectorLabel dflags upd_flag offset+thunkEntryLabel dflags thunk_id c _ _+  = enterIdLabel dflags thunk_id c++enterApLabel :: DynFlags -> Bool -> Arity -> CLabel+enterApLabel dflags is_updatable arity+  | tablesNextToCode dflags = mkApInfoTableLabel is_updatable arity+  | otherwise               = mkApEntryLabel is_updatable arity++enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel+enterSelectorLabel dflags upd_flag offset+  | tablesNextToCode dflags = mkSelectorInfoLabel upd_flag offset+  | otherwise               = mkSelectorEntryLabel upd_flag offset++enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel+enterIdLabel dflags id c+  | tablesNextToCode dflags = mkInfoTableLabel id c+  | otherwise               = mkEntryLabel id c+++--------------------------------------+--   Profiling+--------------------------------------++-- Profiling requires two pieces of information to be determined for+-- each closure's info table --- description and type.++-- The description is stored directly in the @CClosureInfoTable@ when the+-- info table is built.++-- The type is determined from the type information stored with the @Id@+-- in the closure info using @closureTypeDescr@.++mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo+mkProfilingInfo dflags id val_descr+  | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo+  | otherwise = ProfilingInfo ty_descr_w8 (BS8.pack val_descr)+  where+    ty_descr_w8  = BS8.pack (getTyDescription (idType id))++getTyDescription :: Type -> String+getTyDescription ty+  = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->+    case tau_ty of+      TyVarTy _              -> "*"+      AppTy fun _            -> getTyDescription fun+      TyConApp tycon _       -> getOccString tycon+      FunTy {}              -> '-' : fun_result tau_ty+      ForAllTy _  ty         -> getTyDescription ty+      LitTy n                -> getTyLitDescription n+      CastTy ty _            -> getTyDescription ty+      CoercionTy co          -> pprPanic "getTyDescription" (ppr co)+    }+  where+    fun_result (FunTy { ft_res = res }) = '>' : fun_result res+    fun_result other                    = getTyDescription other++getTyLitDescription :: TyLit -> String+getTyLitDescription l =+  case l of+    NumTyLit n -> show n+    StrTyLit n -> show n++--------------------------------------+--   CmmInfoTable-related things+--------------------------------------++mkDataConInfoTable :: DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable+mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds+ = CmmInfoTable { cit_lbl  = info_lbl+                , cit_rep  = sm_rep+                , cit_prof = prof+                , cit_srt  = Nothing+                , cit_clo  = Nothing }+ where+   name = dataConName data_con+   info_lbl = mkConInfoTableLabel name NoCafRefs+   sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type+   cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con)+                  -- We keep the *zero-indexed* tag in the srt_len field+                  -- of the info table of a data constructor.++   prof | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo+        | otherwise                            = ProfilingInfo ty_descr val_descr++   ty_descr  = BS8.pack $ occNameString $ getOccName $ dataConTyCon data_con+   val_descr = BS8.pack $ occNameString $ getOccName data_con++-- We need a black-hole closure info to pass to @allocDynClosure@ when we+-- want to allocate the black hole on entry to a CAF.++cafBlackHoleInfoTable :: CmmInfoTable+cafBlackHoleInfoTable+  = CmmInfoTable { cit_lbl  = mkCAFBlackHoleInfoTableLabel+                 , cit_rep  = blackHoleRep+                 , cit_prof = NoProfilingInfo+                 , cit_srt  = Nothing+                 , cit_clo  = Nothing }++indStaticInfoTable :: CmmInfoTable+indStaticInfoTable+  = CmmInfoTable { cit_lbl  = mkIndStaticInfoLabel+                 , cit_rep  = indStaticRep+                 , cit_prof = NoProfilingInfo+                 , cit_srt  = Nothing+                 , cit_clo  = Nothing }++staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool+-- A static closure needs a link field to aid the GC when traversing+-- the static closure graph.  But it only needs such a field if either+--        a) it has an SRT+--        b) it's a constructor with one or more pointer fields+-- In case (b), the constructor's fields themselves play the role+-- of the SRT.+staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep }+  | isConRep smrep         = not (isStaticNoCafCon smrep)+  | otherwise              = has_srt
+ compiler/GHC/StgToCmm/DataCon.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Stg to C--: code generation for constructors+--+-- This module provides the support code for StgToCmm to deal with with+-- constructors on the RHSs of let(rec)s.+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.DataCon (+        cgTopRhsCon, buildDynCon, bindConArgs+    ) where++#include "HsVersions.h"++import GhcPrelude++import StgSyn+import CoreSyn  ( AltCon(..) )++import GHC.StgToCmm.Monad+import GHC.StgToCmm.Env+import GHC.StgToCmm.Heap+import GHC.StgToCmm.Layout+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Closure++import CmmExpr+import CmmUtils+import CLabel+import MkGraph+import SMRep+import CostCentre+import Module+import DataCon+import DynFlags+import FastString+import Id+import RepType (countConRepArgs)+import Literal+import PrelInfo+import Outputable+import GHC.Platform+import Util+import MonadUtils (mapMaybeM)++import Control.Monad+import Data.Char++++---------------------------------------------------------------+--      Top-level constructors+---------------------------------------------------------------++cgTopRhsCon :: DynFlags+            -> Id               -- Name of thing bound to this RHS+            -> DataCon          -- Id+            -> [NonVoid StgArg] -- Args+            -> (CgIdInfo, FCode ())+cgTopRhsCon dflags id con args =+    let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label)+    in (id_info, gen_code)+  where+   name          = idName id+   caffy         = idCafInfo id -- any stgArgHasCafRefs args+   closure_label = mkClosureLabel name caffy++   gen_code =+     do { this_mod <- getModuleName+        ; when (platformOS (targetPlatform dflags) == OSMinGW32) $+              -- Windows DLLs have a problem with static cross-DLL refs.+              MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) )+        ; ASSERT( args `lengthIs` countConRepArgs con ) return ()++        -- LAY IT OUT+        ; let+            (tot_wds, --  #ptr_wds + #nonptr_wds+             ptr_wds, --  #ptr_wds+             nv_args_w_offsets) =+                 mkVirtHeapOffsetsWithPadding dflags StdHeader (addArgReps args)++            mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))+            mk_payload (FieldOff arg _) = do+                amode <- getArgAmode arg+                case amode of+                  CmmLit lit -> return lit+                  _          -> panic "GHC.StgToCmm.DataCon.cgTopRhsCon"++            nonptr_wds = tot_wds - ptr_wds++             -- we're not really going to emit an info table, so having+             -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields+             -- needs to poke around inside it.+            info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds+++        ; payload <- mapM mk_payload nv_args_w_offsets+                -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs+                -- NB2: all the amodes should be Lits!+                --      TODO (osa): Why?++        ; let closure_rep = mkStaticClosureFields+                             dflags+                             info_tbl+                             dontCareCCS                -- Because it's static data+                             caffy                      -- Has CAF refs+                             payload++                -- BUILD THE OBJECT+        ; emitDataLits closure_label closure_rep++        ; return () }+++---------------------------------------------------------------+--      Lay out and allocate non-top-level constructors+---------------------------------------------------------------++buildDynCon :: Id                 -- Name of the thing to which this constr will+                                  -- be bound+            -> Bool               -- is it genuinely bound to that name, or just+                                  -- for profiling?+            -> CostCentreStack    -- Where to grab cost centre from;+                                  -- current CCS if currentOrSubsumedCCS+            -> DataCon            -- The data constructor+            -> [NonVoid StgArg]   -- Its args+            -> FCode (CgIdInfo, FCode CmmAGraph)+               -- Return details about how to find it and initialization code+buildDynCon binder actually_bound cc con args+    = do dflags <- getDynFlags+         buildDynCon' dflags (targetPlatform dflags) binder actually_bound cc con args+++buildDynCon' :: DynFlags+             -> Platform+             -> Id -> Bool+             -> CostCentreStack+             -> DataCon+             -> [NonVoid StgArg]+             -> FCode (CgIdInfo, FCode CmmAGraph)++{- We used to pass a boolean indicating whether all the+args were of size zero, so we could use a static+constructor; but I concluded that it just isn't worth it.+Now I/O uses unboxed tuples there just aren't any constructors+with all size-zero args.++The reason for having a separate argument, rather than looking at+the addr modes of the args is that we may be in a "knot", and+premature looking at the args will cause the compiler to black-hole!+-}+++-------- buildDynCon': Nullary constructors --------------+-- First we deal with the case of zero-arity constructors.  They+-- will probably be unfolded, so we don't expect to see this case much,+-- if at all, but it does no harm, and sets the scene for characters.+--+-- In the case of zero-arity constructors, or, more accurately, those+-- which have exclusively size-zero (VoidRep) args, we generate no code+-- at all.++buildDynCon' dflags _ binder _ _cc con []+  | isNullaryRepDataCon con+  = return (litIdInfo dflags binder (mkConLFInfo con)+                (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))),+            return mkNop)++-------- buildDynCon': Charlike and Intlike constructors -----------+{- The following three paragraphs about @Char@-like and @Int@-like+closures are obsolete, but I don't understand the details well enough+to properly word them, sorry. I've changed the treatment of @Char@s to+be analogous to @Int@s: only a subset is preallocated, because @Char@+has now 31 bits. Only literals are handled here. -- Qrczak++Now for @Char@-like closures.  We generate an assignment of the+address of the closure to a temporary.  It would be possible simply to+generate no code, and record the addressing mode in the environment,+but we'd have to be careful if the argument wasn't a constant --- so+for simplicity we just always assign to a temporary.++Last special case: @Int@-like closures.  We only special-case the+situation in which the argument is a literal in the range+@mIN_INTLIKE@..@mAX_INTLILKE@.  NB: for @Char@-like closures we can+work with any old argument, but for @Int@-like ones the argument has+to be a literal.  Reason: @Char@ like closures have an argument type+which is guaranteed in range.++Because of this, we use can safely return an addressing mode.++We don't support this optimisation when compiling into Windows DLLs yet+because they don't support cross package data references well.+-}++buildDynCon' dflags platform binder _ _cc con [arg]+  | maybeIntLikeCon con+  , platformOS platform /= OSMinGW32 || not (positionIndependent dflags)+  , NonVoid (StgLitArg (LitNumber LitNumInt val _)) <- arg+  , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer!+  , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto...+  = do  { let intlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit "stg_INTLIKE")+              val_int = fromIntegral val :: Int+              offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSizeW dflags + 1)+                -- INTLIKE closures consist of a header and one word payload+              intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW+        ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode+                 , return mkNop) }++buildDynCon' dflags platform binder _ _cc con [arg]+  | maybeCharLikeCon con+  , platformOS platform /= OSMinGW32 || not (positionIndependent dflags)+  , NonVoid (StgLitArg (LitChar val)) <- arg+  , let val_int = ord val :: Int+  , val_int <= mAX_CHARLIKE dflags+  , val_int >= mIN_CHARLIKE dflags+  = do  { let charlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit "stg_CHARLIKE")+              offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSizeW dflags + 1)+                -- CHARLIKE closures consist of a header and one word payload+              charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW+        ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode+                 , return mkNop) }++-------- buildDynCon': the general case -----------+buildDynCon' dflags _ binder actually_bound ccs con args+  = do  { (id_info, reg) <- rhsIdInfo binder lf_info+        ; return (id_info, gen_code reg)+        }+ where+  lf_info = mkConLFInfo con++  gen_code reg+    = do  { let (tot_wds, ptr_wds, args_w_offsets)+                  = mkVirtConstrOffsets dflags (addArgReps args)+                nonptr_wds = tot_wds - ptr_wds+                info_tbl = mkDataConInfoTable dflags con False+                                ptr_wds nonptr_wds+          ; let ticky_name | actually_bound = Just binder+                           | otherwise = Nothing++          ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info+                                          use_cc blame_cc args_w_offsets+          ; return (mkRhsInit dflags reg lf_info hp_plus_n) }+    where+      use_cc      -- cost-centre to stick in the object+        | isCurrentCCS ccs = cccsExpr+        | otherwise        = panic "buildDynCon: non-current CCS not implemented"++      blame_cc = use_cc -- cost-centre on which to blame the alloc (same)+++---------------------------------------------------------------+--      Binding constructor arguments+---------------------------------------------------------------++bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]+-- bindConArgs is called from cgAlt of a case+-- (bindConArgs con args) augments the environment with bindings for the+-- binders args, assuming that we have just returned from a 'case' which+-- found a con+bindConArgs (DataAlt con) base args+  = ASSERT(not (isUnboxedTupleCon con))+    do dflags <- getDynFlags+       let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args)+           tag = tagForCon dflags con++           -- The binding below forces the masking out of the tag bits+           -- when accessing the constructor field.+           bind_arg :: (NonVoid Id, ByteOff) -> FCode (Maybe LocalReg)+           bind_arg (arg@(NonVoid b), offset)+             | isDeadBinder b  -- See Note [Dead-binder optimisation] in GHC.StgToCmm.Expr+             = return Nothing+             | otherwise+             = do { emit $ mkTaggedObjectLoad dflags (idToReg dflags arg)+                                              base offset tag+                  ; Just <$> bindArgToReg arg }++       mapMaybeM bind_arg args_w_offsets++bindConArgs _other_con _base args+  = ASSERT( null args ) return []
+ compiler/GHC/StgToCmm/Env.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Stg to C-- code generation: the binding environment+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------+module GHC.StgToCmm.Env (+        CgIdInfo,++        litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,+        idInfoToAmode,++        addBindC, addBindsC,++        bindArgsToRegs, bindToReg, rebindToReg,+        bindArgToReg, idToReg,+        getArgAmode, getNonVoidArgAmodes,+        getCgIdInfo,+        maybeLetNoEscape,+    ) where++#include "HsVersions.h"++import GhcPrelude++import TyCon+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Closure++import CLabel++import BlockId+import CmmExpr+import CmmUtils+import DynFlags+import Id+import MkGraph+import Name+import Outputable+import StgSyn+import Type+import TysPrim+import UniqFM+import Util+import VarEnv++-------------------------------------+--        Manipulating CgIdInfo+-------------------------------------++mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo+mkCgIdInfo id lf expr+  = CgIdInfo { cg_id = id, cg_lf = lf+             , cg_loc = CmmLoc expr }++litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo+litIdInfo dflags id lf lit+  = CgIdInfo { cg_id = id, cg_lf = lf+             , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) }+  where+    tag = lfDynTag dflags lf++lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo+lneIdInfo dflags id regs+  = CgIdInfo { cg_id = id, cg_lf = lf+             , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) }+  where+    lf     = mkLFLetNoEscape+    blk_id = mkBlockId (idUnique id)+++rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)+rhsIdInfo id lf_info+  = do dflags <- getDynFlags+       reg <- newTemp (gcWord dflags)+       return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)++mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph+mkRhsInit dflags reg lf_info expr+  = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info))++idInfoToAmode :: CgIdInfo -> CmmExpr+-- Returns a CmmExpr for the *tagged* pointer+idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e+idInfoToAmode cg_info+  = pprPanic "idInfoToAmode" (ppr (cg_id cg_info))        -- LneLoc++addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr+-- A tag adds a byte offset to the pointer+addDynTag dflags expr tag = cmmOffsetB dflags expr tag++maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])+maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)+maybeLetNoEscape _other                                      = Nothing++++---------------------------------------------------------+--        The binding environment+--+-- There are three basic routines, for adding (addBindC),+-- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.+---------------------------------------------------------++addBindC :: CgIdInfo -> FCode ()+addBindC stuff_to_bind = do+        binds <- getBinds+        setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind++addBindsC :: [CgIdInfo] -> FCode ()+addBindsC new_bindings = do+        binds <- getBinds+        let new_binds = foldl' (\ binds info -> extendVarEnv binds (cg_id info) info)+                               binds+                               new_bindings+        setBinds new_binds++getCgIdInfo :: Id -> FCode CgIdInfo+getCgIdInfo id+  = do  { dflags <- getDynFlags+        ; local_binds <- getBinds -- Try local bindings first+        ; case lookupVarEnv local_binds id of {+            Just info -> return info ;+            Nothing   -> do {++                -- Should be imported; make up a CgIdInfo for it+          let name = idName id+        ; if isExternalName name then+              let ext_lbl+                      | isUnliftedType (idType id) =+                          -- An unlifted external Id must refer to a top-level+                          -- string literal. See Note [Bytes label] in CLabel.+                          ASSERT( idType id `eqType` addrPrimTy )+                          mkBytesLabel name+                      | otherwise = mkClosureLabel name $ idCafInfo id+              in return $+                  litIdInfo dflags id (mkLFImported id) (CmmLabel ext_lbl)+          else+              cgLookupPanic id -- Bug+        }}}++cgLookupPanic :: Id -> FCode a+cgLookupPanic id+  = do  local_binds <- getBinds+        pprPanic "GHC.StgToCmm.Env: variable not found"+                (vcat [ppr id,+                text "local binds for:",+                pprUFM local_binds $ \infos ->+                  vcat [ ppr (cg_id info) | info <- infos ]+              ])+++--------------------+getArgAmode :: NonVoid StgArg -> FCode CmmExpr+getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var+getArgAmode (NonVoid (StgLitArg lit)) = CmmLit <$> cgLit lit++getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]+-- NB: Filters out void args,+--     so the result list may be shorter than the argument list+getNonVoidArgAmodes [] = return []+getNonVoidArgAmodes (arg:args)+  | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args+  | otherwise = do { amode  <- getArgAmode (NonVoid arg)+                   ; amodes <- getNonVoidArgAmodes args+                   ; return ( amode : amodes ) }+++------------------------------------------------------------------------+--        Interface functions for binding and re-binding names+------------------------------------------------------------------------++bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg+-- Bind an Id to a fresh LocalReg+bindToReg nvid@(NonVoid id) lf_info+  = do dflags <- getDynFlags+       let reg = idToReg dflags nvid+       addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))+       return reg++rebindToReg :: NonVoid Id -> FCode LocalReg+-- Like bindToReg, but the Id is already in scope, so+-- get its LF info from the envt+rebindToReg nvid@(NonVoid id)+  = do  { info <- getCgIdInfo id+        ; bindToReg nvid (cg_lf info) }++bindArgToReg :: NonVoid Id -> FCode LocalReg+bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)++bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]+bindArgsToRegs args = mapM bindArgToReg args++idToReg :: DynFlags -> NonVoid Id -> LocalReg+-- Make a register from an Id, typically a function argument,+-- free variable, or case binder+--+-- We re-use the Unique from the Id to make it easier to see what is going on+--+-- By now the Ids should be uniquely named; else one would worry+-- about accidental collision+idToReg dflags (NonVoid id)+             = LocalReg (idUnique id)+                        (primRepCmmType dflags (idPrimRep id))
+ compiler/GHC/StgToCmm/Expr.hs view
@@ -0,0 +1,1158 @@+{-# LANGUAGE CPP, BangPatterns #-}++-----------------------------------------------------------------------------+--+-- Stg to C-- code generation: expressions+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Expr ( cgExpr ) where++#include "HsVersions.h"++import GhcPrelude hiding ((<*>))++import {-# SOURCE #-} GHC.StgToCmm.Bind ( cgBind )++import GHC.StgToCmm.Monad+import GHC.StgToCmm.Heap+import GHC.StgToCmm.Env+import GHC.StgToCmm.DataCon+import GHC.StgToCmm.Prof (saveCurrentCostCentre, restoreCurrentCostCentre, emitSetCCC)+import GHC.StgToCmm.Layout+import GHC.StgToCmm.Prim+import GHC.StgToCmm.Hpc+import GHC.StgToCmm.Ticky+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Closure++import StgSyn++import MkGraph+import BlockId+import Cmm hiding ( succ )+import CmmInfo+import CoreSyn+import DataCon+import DynFlags         ( mAX_PTR_TAG )+import ForeignCall+import Id+import PrimOp+import TyCon+import Type             ( isUnliftedType )+import RepType          ( isVoidTy, countConRepArgs )+import CostCentre       ( CostCentreStack, currentCCS )+import Maybes+import Util+import FastString+import Outputable++import Control.Monad ( unless, void )+import Control.Arrow ( first )+import Data.List     ( partition )++------------------------------------------------------------------------+--              cgExpr: the main function+------------------------------------------------------------------------++cgExpr  :: CgStgExpr -> FCode ReturnKind++cgExpr (StgApp fun args)     = cgIdApp fun args++-- seq# a s ==> a+-- See Note [seq# magic] in PrelRules+cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =+  cgIdApp a []++-- dataToTag# :: a -> Int#+-- See Note [dataToTag#] in primops.txt.pp+cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do+  dflags <- getDynFlags+  emitComment (mkFastString "dataToTag#")+  tmp <- newTemp (bWord dflags)+  _ <- withSequel (AssignTo [tmp] False) (cgIdApp a [])+  -- TODO: For small types look at the tag bits instead of reading info table+  emitReturn [getConstrTag dflags (cmmUntag dflags (CmmReg (CmmLocal tmp)))]++cgExpr (StgOpApp op args ty) = cgOpApp op args ty+cgExpr (StgConApp con args _)= cgConApp con args+cgExpr (StgTick t e)         = cgTick t >> cgExpr e+cgExpr (StgLit lit)       = do cmm_lit <- cgLit lit+                               emitReturn [CmmLit cmm_lit]++cgExpr (StgLet _ binds expr) = do { cgBind binds;     cgExpr expr }+cgExpr (StgLetNoEscape _ binds expr) =+  do { u <- newUnique+     ; let join_id = mkBlockId u+     ; cgLneBinds join_id binds+     ; r <- cgExpr expr+     ; emitLabel join_id+     ; return r }++cgExpr (StgCase expr bndr alt_type alts) =+  cgCase expr bndr alt_type alts++cgExpr (StgLam {}) = panic "cgExpr: StgLam"++------------------------------------------------------------------------+--              Let no escape+------------------------------------------------------------------------++{- Generating code for a let-no-escape binding, aka join point is very+very similar to what we do for a case expression.  The duality is+between+        let-no-escape x = b+        in e+and+        case e of ... -> b++That is, the RHS of 'x' (ie 'b') will execute *later*, just like+the alternative of the case; it needs to be compiled in an environment+in which all volatile bindings are forgotten, and the free vars are+bound only to stable things like stack locations..  The 'e' part will+execute *next*, just like the scrutinee of a case. -}++-------------------------+cgLneBinds :: BlockId -> CgStgBinding -> FCode ()+cgLneBinds join_id (StgNonRec bndr rhs)+  = do  { local_cc <- saveCurrentCostCentre+                -- See Note [Saving the current cost centre]+        ; (info, fcode) <- cgLetNoEscapeRhs join_id local_cc bndr rhs+        ; fcode+        ; addBindC info }++cgLneBinds join_id (StgRec pairs)+  = do  { local_cc <- saveCurrentCostCentre+        ; r <- sequence $ unzipWith (cgLetNoEscapeRhs join_id local_cc) pairs+        ; let (infos, fcodes) = unzip r+        ; addBindsC infos+        ; sequence_ fcodes+        }++-------------------------+cgLetNoEscapeRhs+    :: BlockId          -- join point for successor of let-no-escape+    -> Maybe LocalReg   -- Saved cost centre+    -> Id+    -> CgStgRhs+    -> FCode (CgIdInfo, FCode ())++cgLetNoEscapeRhs join_id local_cc bndr rhs =+  do { (info, rhs_code) <- cgLetNoEscapeRhsBody local_cc bndr rhs+     ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info+     ; let code = do { (_, body) <- getCodeScoped rhs_code+                     ; emitOutOfLine bid (first (<*> mkBranch join_id) body) }+     ; return (info, code)+     }++cgLetNoEscapeRhsBody+    :: Maybe LocalReg   -- Saved cost centre+    -> Id+    -> CgStgRhs+    -> FCode (CgIdInfo, FCode ())+cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure _ cc _upd args body)+  = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body+cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)+  = cgLetNoEscapeClosure bndr local_cc cc []+      (StgConApp con args (pprPanic "cgLetNoEscapeRhsBody" $+                           text "StgRhsCon doesn't have type args"))+        -- For a constructor RHS we want to generate a single chunk of+        -- code which can be jumped to from many places, which will+        -- return the constructor. It's easy; just behave as if it+        -- was an StgRhsClosure with a ConApp inside!++-------------------------+cgLetNoEscapeClosure+        :: Id                   -- binder+        -> Maybe LocalReg       -- Slot for saved current cost centre+        -> CostCentreStack      -- XXX: *** NOT USED *** why not?+        -> [NonVoid Id]         -- Args (as in \ args -> body)+        -> CgStgExpr            -- Body (as in above)+        -> FCode (CgIdInfo, FCode ())++cgLetNoEscapeClosure bndr cc_slot _unused_cc args body+  = do dflags <- getDynFlags+       return ( lneIdInfo dflags bndr args+              , code )+  where+   code = forkLneBody $ do {+            ; withNewTickyCounterLNE (idName bndr) args $ do+            ; restoreCurrentCostCentre cc_slot+            ; arg_regs <- bindArgsToRegs args+            ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) }+++------------------------------------------------------------------------+--              Case expressions+------------------------------------------------------------------------++{- Note [Compiling case expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is quite interesting to decide whether to put a heap-check at the+start of each alternative.  Of course we certainly have to do so if+the case forces an evaluation, or if there is a primitive op which can+trigger GC.++A more interesting situation is this (a Plan-B situation)++        !P!;+        ...P...+        case x# of+          0#      -> !Q!; ...Q...+          default -> !R!; ...R...++where !x! indicates a possible heap-check point. The heap checks+in the alternatives *can* be omitted, in which case the topmost+heapcheck will take their worst case into account.++In favour of omitting !Q!, !R!:++ - *May* save a heap overflow test,+   if ...P... allocates anything.++ - We can use relative addressing from a single Hp to+   get at all the closures so allocated.++ - No need to save volatile vars etc across heap checks+   in !Q!, !R!++Against omitting !Q!, !R!++  - May put a heap-check into the inner loop.  Suppose+        the main loop is P -> R -> P -> R...+        Q is the loop exit, and only it does allocation.+    This only hurts us if P does no allocation.  If P allocates,+    then there is a heap check in the inner loop anyway.++  - May do more allocation than reqd.  This sometimes bites us+    badly.  For example, nfib (ha!) allocates about 30\% more space if the+    worst-casing is done, because many many calls to nfib are leaf calls+    which don't need to allocate anything.++    We can un-allocate, but that costs an instruction++Neither problem hurts us if there is only one alternative.++Suppose the inner loop is P->R->P->R etc.  Then here is+how many heap checks we get in the *inner loop* under various+conditions++  Alloc   Heap check in branches (!Q!, !R!)?+  P Q R      yes     no (absorb to !P!)+--------------------------------------+  n n n      0          0+  n y n      0          1+  n . y      1          1+  y . y      2          1+  y . n      1          1++Best choices: absorb heap checks from Q and R into !P! iff+  a) P itself does some allocation+or+  b) P does allocation, or there is exactly one alternative++We adopt (b) because that is more likely to put the heap check at the+entry to a function, when not many things are live.  After a bunch of+single-branch cases, we may have lots of things live++Hence: two basic plans for++        case e of r { alts }++------ Plan A: the general case ---------++        ...save current cost centre...++        ...code for e,+           with sequel (SetLocals r)++        ...restore current cost centre...+        ...code for alts...+        ...alts do their own heap checks++------ Plan B: special case when ---------+  (i)  e does not allocate or call GC+  (ii) either upstream code performs allocation+       or there is just one alternative++  Then heap allocation in the (single) case branch+  is absorbed by the upstream check.+  Very common example: primops on unboxed values++        ...code for e,+           with sequel (SetLocals r)...++        ...code for alts...+        ...no heap check...+-}++++-------------------------------------+data GcPlan+  = GcInAlts            -- Put a GC check at the start the case alternatives,+        [LocalReg]      -- which binds these registers+  | NoGcInAlts          -- The scrutinee is a primitive value, or a call to a+                        -- primitive op which does no GC.  Absorb the allocation+                        -- of the case alternative(s) into the upstream check++-------------------------------------+cgCase :: CgStgExpr -> Id -> AltType -> [CgStgAlt] -> FCode ReturnKind++cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts+  | isEnumerationTyCon tycon -- Note [case on bool]+  = do { tag_expr <- do_enum_primop op args++       -- If the binder is not dead, convert the tag to a constructor+       -- and assign it. See Note [Dead-binder optimisation]+       ; unless (isDeadBinder bndr) $ do+            { dflags <- getDynFlags+            ; tmp_reg <- bindArgToReg (NonVoid bndr)+            ; emitAssign (CmmLocal tmp_reg)+                         (tagToClosure dflags tycon tag_expr) }++       ; (mb_deflt, branches) <- cgAlgAltRhss (NoGcInAlts,AssignedDirectly)+                                              (NonVoid bndr) alts+                                 -- See Note [GC for conditionals]+       ; emitSwitch tag_expr branches mb_deflt 0 (tyConFamilySize tycon - 1)+       ; return AssignedDirectly+       }+  where+    do_enum_primop :: PrimOp -> [StgArg] -> FCode CmmExpr+    do_enum_primop TagToEnumOp [arg]  -- No code!+      = getArgAmode (NonVoid arg)+    do_enum_primop primop args+      = do dflags <- getDynFlags+           tmp <- newTemp (bWord dflags)+           cgPrimOp [tmp] primop args+           return (CmmReg (CmmLocal tmp))++{-+Note [case on bool]+~~~~~~~~~~~~~~~~~~~+This special case handles code like++  case a <# b of+    True ->+    False ->++-->  case tagToEnum# (a <$# b) of+        True -> .. ; False -> ...++--> case (a <$# b) of r ->+    case tagToEnum# r of+        True -> .. ; False -> ...++If we let the ordinary case code handle it, we'll get something like++ tmp1 = a < b+ tmp2 = Bool_closure_tbl[tmp1]+ if (tmp2 & 7 != 0) then ... // normal tagged case++but this junk won't optimise away.  What we really want is just an+inline comparison:++ if (a < b) then ...++So we add a special case to generate++ tmp1 = a < b+ if (tmp1 == 0) then ...++and later optimisations will further improve this.++Now that #6135 has been resolved it should be possible to remove that+special case. The idea behind this special case and pre-6135 implementation+of Bool-returning primops was that tagToEnum# was added implicitly in the+codegen and then optimized away. Now the call to tagToEnum# is explicit+in the source code, which allows to optimize it away at the earlier stages+of compilation (i.e. at the Core level).++Note [Scrutinising VoidRep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have this STG code:+   f = \[s : State# RealWorld] ->+       case s of _ -> blah+This is very odd.  Why are we scrutinising a state token?  But it+can arise with bizarre NOINLINE pragmas (#9964)+    crash :: IO ()+    crash = IO (\s -> let {-# NOINLINE s' #-}+                          s' = s+                      in (# s', () #))++Now the trouble is that 's' has VoidRep, and we do not bind void+arguments in the environment; they don't live anywhere.  See the+calls to nonVoidIds in various places.  So we must not look up+'s' in the environment.  Instead, just evaluate the RHS!  Simple.++Note [Dead-binder optimisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A case-binder, or data-constructor argument, may be marked as dead,+because we preserve occurrence-info on binders in CoreTidy (see+CoreTidy.tidyIdBndr).++If the binder is dead, we can sometimes eliminate a load.  While+CmmSink will eliminate that load, it's very easy to kill it at source+(giving CmmSink less work to do), and in any case CmmSink only runs+with -O. Since the majority of case binders are dead, this+optimisation probably still has a great benefit-cost ratio and we want+to keep it for -O0. See also Phab:D5358.++This probably also was the reason for occurrence hack in Phab:D5339 to+exist, perhaps because the occurrence information preserved by+'CoreTidy.tidyIdBndr' was insufficient.  But now that CmmSink does the+job we deleted the hacks.+-}++cgCase (StgApp v []) _ (PrimAlt _) alts+  | isVoidRep (idPrimRep v)  -- See Note [Scrutinising VoidRep]+  , [(DEFAULT, _, rhs)] <- alts+  = cgExpr rhs++{- Note [Dodgy unsafeCoerce 1]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    case (x :: HValue) |> co of (y :: MutVar# Int)+        DEFAULT -> ...+We want to generate an assignment+     y := x+We want to allow this assignment to be generated in the case when the+types are compatible, because this allows some slightly-dodgy but+occasionally-useful casts to be used, such as in RtClosureInspect+where we cast an HValue to a MutVar# so we can print out the contents+of the MutVar#.  If instead we generate code that enters the HValue,+then we'll get a runtime panic, because the HValue really is a+MutVar#.  The types are compatible though, so we can just generate an+assignment.+-}+cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts+  | isUnliftedType (idType v)  -- Note [Dodgy unsafeCoerce 1]+  = -- assignment suffices for unlifted types+    do { dflags <- getDynFlags+       ; unless (reps_compatible dflags) $+           pprPanic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"+                    (pp_bndr v $$ pp_bndr bndr)+       ; v_info <- getCgIdInfo v+       ; emitAssign (CmmLocal (idToReg dflags (NonVoid bndr)))+                    (idInfoToAmode v_info)+       -- Add bndr to the environment+       ; _ <- bindArgToReg (NonVoid bndr)+       ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts }+  where+    reps_compatible dflags = primRepCompatible dflags (idPrimRep v) (idPrimRep bndr)++    pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id))++{- Note [Dodgy unsafeCoerce 2, #3132]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In all other cases of a lifted Id being cast to an unlifted type, the+Id should be bound to bottom, otherwise this is an unsafe use of+unsafeCoerce.  We can generate code to enter the Id and assume that+it will never return.  Hence, we emit the usual enter/return code, and+because bottom must be untagged, it will be entered.  The Sequel is a+type-correct assignment, albeit bogus.  The (dead) continuation loops;+it would be better to invoke some kind of panic function here.+-}+cgCase scrut@(StgApp v []) _ (PrimAlt _) _+  = do { dflags <- getDynFlags+       ; mb_cc <- maybeSaveCostCentre True+       ; _ <- withSequel+                  (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut)+       ; restoreCurrentCostCentre mb_cc+       ; emitComment $ mkFastString "should be unreachable code"+       ; l <- newBlockId+       ; emitLabel l+       ; emit (mkBranch l)  -- an infinite loop+       ; return AssignedDirectly+       }++{- Note [Handle seq#]+~~~~~~~~~~~~~~~~~~~~~+See Note [seq# magic] in PrelRules.+The special case for seq# in cgCase does this:++  case seq# a s of v+    (# s', a' #) -> e+==>+  case a of v+    (# s', a' #) -> e++(taking advantage of the fact that the return convention for (# State#, a #)+is the same as the return convention for just 'a')+-}++cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts+  = -- Note [Handle seq#]+    -- And see Note [seq# magic] in PrelRules+    -- Use the same return convention as vanilla 'a'.+    cgCase (StgApp a []) bndr alt_type alts++cgCase scrut bndr alt_type alts+  = -- the general case+    do { dflags <- getDynFlags+       ; up_hp_usg <- getVirtHp        -- Upstream heap usage+       ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts+             alt_regs  = map (idToReg dflags) ret_bndrs+       ; simple_scrut <- isSimpleScrut scrut alt_type+       ; let do_gc  | is_cmp_op scrut  = False  -- See Note [GC for conditionals]+                    | not simple_scrut = True+                    | isSingleton alts = False+                    | up_hp_usg > 0    = False+                    | otherwise        = True+               -- cf Note [Compiling case expressions]+             gc_plan = if do_gc then GcInAlts alt_regs else NoGcInAlts++       ; mb_cc <- maybeSaveCostCentre simple_scrut++       ; let sequel = AssignTo alt_regs do_gc{- Note [scrut sequel] -}+       ; ret_kind <- withSequel sequel (cgExpr scrut)+       ; restoreCurrentCostCentre mb_cc+       ; _ <- bindArgsToRegs ret_bndrs+       ; cgAlts (gc_plan,ret_kind) (NonVoid bndr) alt_type alts+       }+  where+    is_cmp_op (StgOpApp (StgPrimOp op) _ _) = isComparisonPrimOp op+    is_cmp_op _                             = False++{- Note [GC for conditionals]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For boolean conditionals it seems that we have always done NoGcInAlts.+That is, we have always done the GC check before the conditional.+This is enshrined in the special case for+   case tagToEnum# (a>b) of ...+See Note [case on bool]++It's odd, and it's flagrantly inconsistent with the rules described+Note [Compiling case expressions].  However, after eliminating the+tagToEnum# (#13397) we will have:+   case (a>b) of ...+Rather than make it behave quite differently, I am testing for a+comparison operator here in in the general case as well.++ToDo: figure out what the Right Rule should be.++Note [scrut sequel]+~~~~~~~~~~~~~~~~~~~+The job of the scrutinee is to assign its value(s) to alt_regs.+Additionally, if we plan to do a heap-check in the alternatives (see+Note [Compiling case expressions]), then we *must* retreat Hp to+recover any unused heap before passing control to the sequel.  If we+don't do this, then any unused heap will become slop because the heap+check will reset the heap usage. Slop in the heap breaks LDV profiling+(+RTS -hb) which needs to do a linear sweep through the nursery.+++Note [Inlining out-of-line primops and heap checks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If shouldInlinePrimOp returns True when called from GHC.StgToCmm.Expr for the+purpose of heap check placement, we *must* inline the primop later in+GHC.StgToCmm.Prim. If we don't things will go wrong.+-}++-----------------+maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg)+maybeSaveCostCentre simple_scrut+  | simple_scrut = return Nothing+  | otherwise    = saveCurrentCostCentre+++-----------------+isSimpleScrut :: CgStgExpr -> AltType -> FCode Bool+-- Simple scrutinee, does not block or allocate; hence safe to amalgamate+-- heap usage from alternatives into the stuff before the case+-- NB: if you get this wrong, and claim that the expression doesn't allocate+--     when it does, you'll deeply mess up allocation+isSimpleScrut (StgOpApp op args _) _       = isSimpleOp op args+isSimpleScrut (StgLit _)       _           = return True       -- case 1# of { 0# -> ..; ... }+isSimpleScrut (StgApp _ [])    (PrimAlt _) = return True       -- case x# of { 0# -> ..; ... }+isSimpleScrut _                _           = return False++isSimpleOp :: StgOp -> [StgArg] -> FCode Bool+-- True iff the op cannot block or allocate+isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe)+-- dataToTag# evalautes its argument, see Note [dataToTag#] in primops.txt.pp+isSimpleOp (StgPrimOp DataToTagOp) _ = return False+isSimpleOp (StgPrimOp op) stg_args                  = do+    arg_exprs <- getNonVoidArgAmodes stg_args+    dflags <- getDynFlags+    -- See Note [Inlining out-of-line primops and heap checks]+    return $! shouldInlinePrimOp dflags op arg_exprs+isSimpleOp (StgPrimCallOp _) _                           = return False++-----------------+chooseReturnBndrs :: Id -> AltType -> [CgStgAlt] -> [NonVoid Id]+-- These are the binders of a case that are assigned by the evaluation of the+-- scrutinee.+-- They're non-void, see Note [Post-unarisation invariants] in UnariseStg.+chooseReturnBndrs bndr (PrimAlt _) _alts+  = assertNonVoidIds [bndr]++chooseReturnBndrs _bndr (MultiValAlt n) [(_, ids, _)]+  = ASSERT2(ids `lengthIs` n, ppr n $$ ppr ids $$ ppr _bndr)+    assertNonVoidIds ids     -- 'bndr' is not assigned!++chooseReturnBndrs bndr (AlgAlt _) _alts+  = assertNonVoidIds [bndr]  -- Only 'bndr' is assigned++chooseReturnBndrs bndr PolyAlt _alts+  = assertNonVoidIds [bndr]  -- Only 'bndr' is assigned++chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs"+                             -- MultiValAlt has only one alternative++-------------------------------------+cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [CgStgAlt]+       -> FCode ReturnKind+-- At this point the result of the case are in the binders+cgAlts gc_plan _bndr PolyAlt [(_, _, rhs)]+  = maybeAltHeapCheck gc_plan (cgExpr rhs)++cgAlts gc_plan _bndr (MultiValAlt _) [(_, _, rhs)]+  = maybeAltHeapCheck gc_plan (cgExpr rhs)+        -- Here bndrs are *already* in scope, so don't rebind them++cgAlts gc_plan bndr (PrimAlt _) alts+  = do  { dflags <- getDynFlags++        ; tagged_cmms <- cgAltRhss gc_plan bndr alts++        ; let bndr_reg = CmmLocal (idToReg dflags bndr)+              (DEFAULT,deflt) = head tagged_cmms+                -- PrimAlts always have a DEFAULT case+                -- and it always comes first++              tagged_cmms' = [(lit,code)+                             | (LitAlt lit, code) <- tagged_cmms]+        ; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt+        ; return AssignedDirectly }++cgAlts gc_plan bndr (AlgAlt tycon) alts+  = do  { dflags <- getDynFlags++        ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts++        ; 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?+                -- 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, 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+-- code like+--+-- L0:+--   x = R1+--   goto L1+-- L1:+--   if (x & 7 >= 2) then goto L2 else goto L3+-- L2:+--   Hp = Hp + 16+--   if (Hp > HpLim) then goto L4+--   ...+-- L4:+--   call gc() returns to L5+-- 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]+             -> FCode ( Maybe CmmAGraphScoped+                      , [(ConTagZ, CmmAGraphScoped)] )+cgAlgAltRhss gc_plan bndr alts+  = do { tagged_cmms <- cgAltRhss gc_plan bndr alts++       ; let { mb_deflt = case tagged_cmms of+                           ((DEFAULT,rhs) : _) -> Just rhs+                           _other              -> Nothing+                            -- DEFAULT is always first, if present++              ; branches = [ (dataConTagZ con, cmm)+                           | (DataAlt con, cmm) <- tagged_cmms ]+              }++       ; return (mb_deflt, branches)+       }+++-------------------+cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]+          -> FCode [(AltCon, CmmAGraphScoped)]+cgAltRhss gc_plan bndr alts = do+  dflags <- getDynFlags+  let+    base_reg = idToReg dflags bndr+    cg_alt :: CgStgAlt -> FCode (AltCon, CmmAGraphScoped)+    cg_alt (con, bndrs, rhs)+      = getCodeScoped             $+        maybeAltHeapCheck gc_plan $+        do { _ <- bindConArgs con base_reg (assertNonVoidIds bndrs)+                    -- alt binders are always non-void,+                    -- see Note [Post-unarisation invariants] in UnariseStg+           ; _ <- cgExpr rhs+           ; return con }+  forkAlts (map cg_alt alts)++maybeAltHeapCheck :: (GcPlan,ReturnKind) -> FCode a -> FCode a+maybeAltHeapCheck (NoGcInAlts,_)  code = code+maybeAltHeapCheck (GcInAlts regs, AssignedDirectly) code =+  altHeapCheck regs code+maybeAltHeapCheck (GcInAlts regs, ReturnedTo lret off) code =+  altHeapCheckReturnsTo regs lret off code++-----------------------------------------------------------------------------+--      Tail calls+-----------------------------------------------------------------------------++cgConApp :: DataCon -> [StgArg] -> FCode ReturnKind+cgConApp con stg_args+  | isUnboxedTupleCon con       -- Unboxed tuple: assign and return+  = do { arg_exprs <- getNonVoidArgAmodes stg_args+       ; tickyUnboxedTupleReturn (length arg_exprs)+       ; emitReturn arg_exprs }++  | otherwise   --  Boxed constructors; allocate and return+  = ASSERT2( stg_args `lengthIs` countConRepArgs con, ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args )+    do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) False+                                     currentCCS con (assertNonVoidStgArgs stg_args)+                                     -- con args are always non-void,+                                     -- see Note [Post-unarisation invariants] in UnariseStg+                -- The first "con" says that the name bound to this+                -- closure is "con", which is a bit of a fudge, but+                -- it only affects profiling (hence the False)++        ; emit =<< fcode_init+        ; tickyReturnNewCon (length stg_args)+        ; emitReturn [idInfoToAmode idinfo] }++cgIdApp :: Id -> [StgArg] -> FCode ReturnKind+cgIdApp fun_id args = do+    dflags         <- getDynFlags+    fun_info       <- getCgIdInfo fun_id+    self_loop_info <- getSelfLoop+    let fun_arg     = StgVarArg fun_id+        fun_name    = idName    fun_id+        fun         = idInfoToAmode fun_info+        lf_info     = cg_lf         fun_info+        n_args      = length args+        v_args      = length $ filter (isVoidTy . stgArgType) args+        node_points dflags = nodeMustPointToIt dflags lf_info+    case getCallMethod dflags fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of+            -- A value in WHNF, so we can just return it.+        ReturnIt+          | isVoidTy (idType fun_id) -> emitReturn []+          | otherwise                -> emitReturn [fun]+          -- ToDo: does ReturnIt guarantee tagged?++        EnterIt -> ASSERT( null args )  -- Discarding arguments+                   emitEnter fun++        SlowCall -> do      -- A slow function call via the RTS apply routines+                { tickySlowCall lf_info args+                ; emitComment $ mkFastString "slowCall"+                ; slowCall fun args }++        -- A direct function call (possibly with some left-over arguments)+        DirectEntry lbl arity -> do+                { tickyDirectCall arity args+                ; if node_points dflags+                     then directCall NativeNodeCall   lbl arity (fun_arg:args)+                     else directCall NativeDirectCall lbl arity args }++        -- Let-no-escape call or self-recursive tail-call+        JumpToIt blk_id lne_regs -> do+          { adjustHpBackwards -- always do this before a tail-call+          ; cmm_args <- getNonVoidArgAmodes args+          ; emitMultiAssign lne_regs cmm_args+          ; emit (mkBranch blk_id)+          ; return AssignedDirectly }++-- Note [Self-recursive tail calls]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Self-recursive tail calls can be optimized into a local jump in the same+-- way as let-no-escape bindings (see Note [What is a non-escaping let] in+-- stgSyn/CoreToStg.hs). Consider this:+--+-- foo.info:+--     a = R1  // calling convention+--     b = R2+--     goto L1+-- L1: ...+--     ...+-- ...+-- L2: R1 = x+--     R2 = y+--     call foo(R1,R2)+--+-- Instead of putting x and y into registers (or other locations required by the+-- calling convention) and performing a call we can put them into local+-- variables a and b and perform jump to L1:+--+-- foo.info:+--     a = R1+--     b = R2+--     goto L1+-- L1: ...+--     ...+-- ...+-- L2: a = x+--     b = y+--     goto L1+--+-- This can be done only when function is calling itself in a tail position+-- and only if the call passes number of parameters equal to function's arity.+-- Note that this cannot be performed if a function calls itself with a+-- continuation.+--+-- This in fact implements optimization known as "loopification". It was+-- described in "Low-level code optimizations in the Glasgow Haskell Compiler"+-- by Krzysztof Woś, though we use different approach. Krzysztof performed his+-- optimization at the Cmm level, whereas we perform ours during code generation+-- (Stg-to-Cmm pass) essentially making sure that optimized Cmm code is+-- generated in the first place.+--+-- Implementation is spread across a couple of places in the code:+--+--   * FCode monad stores additional information in its reader environment+--     (cgd_self_loop field). This information tells us which function can+--     tail call itself in an optimized way (it is the function currently+--     being compiled), what is the label of a loop header (L1 in example above)+--     and information about local registers in which we should arguments+--     before making a call (this would be a and b in example above).+--+--   * Whenever we are compiling a function, we set that information to reflect+--     the fact that function currently being compiled can be jumped to, instead+--     of called. This is done in closureCodyBody in GHC.StgToCmm.Bind.+--+--   * We also have to emit a label to which we will be jumping. We make sure+--     that the label is placed after a stack check but before the heap+--     check. The reason is that making a recursive tail-call does not increase+--     the stack so we only need to check once. But it may grow the heap, so we+--     have to repeat the heap check in every self-call. This is done in+--     do_checks in GHC.StgToCmm.Heap.+--+--   * When we begin compilation of another closure we remove the additional+--     information from the environment. This is done by forkClosureBody+--     in GHC.StgToCmm.Monad. Other functions that duplicate the environment -+--     forkLneBody, forkAlts, codeOnly - duplicate that information. In other+--     words, we only need to clean the environment of the self-loop information+--     when compiling right hand side of a closure (binding).+--+--   * When compiling a call (cgIdApp) we use getCallMethod to decide what kind+--     of call will be generated. getCallMethod decides to generate a self+--     recursive tail call when (a) environment stores information about+--     possible self tail-call; (b) that tail call is to a function currently+--     being compiled; (c) number of passed non-void arguments is equal to+--     function's arity. (d) loopification is turned on via -floopification+--     command-line option.+--+--   * Command line option to turn loopification on and off is implemented in+--     DynFlags.+--+--+-- Note [Void arguments in self-recursive tail calls]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- State# tokens can get in the way of the loopification optimization as seen in+-- #11372. Consider this:+--+-- foo :: [a]+--     -> (a -> State# s -> (# State s, Bool #))+--     -> State# s+--     -> (# State# s, Maybe a #)+-- foo [] f s = (# s, Nothing #)+-- foo (x:xs) f s = case f x s of+--      (# s', b #) -> case b of+--          True -> (# s', Just x #)+--          False -> foo xs f s'+--+-- We would like to compile the call to foo as a local jump instead of a call+-- (see Note [Self-recursive tail calls]). However, the generated function has+-- an arity of 2 while we apply it to 3 arguments, one of them being of void+-- type. Thus, we mustn't count arguments of void type when checking whether+-- we can turn a call into a self-recursive jump.+--++emitEnter :: CmmExpr -> FCode ReturnKind+emitEnter fun = do+  { dflags <- getDynFlags+  ; adjustHpBackwards+  ; sequel <- getSequel+  ; updfr_off <- getUpdFrameOff+  ; case sequel of+      -- For a return, we have the option of generating a tag-test or+      -- not.  If the value is tagged, we can return directly, which+      -- is quicker than entering the value.  This is a code+      -- size/speed trade-off: when optimising for speed rather than+      -- size we could generate the tag test.+      --+      -- Right now, we do what the old codegen did, and omit the tag+      -- test, just generating an enter.+      Return -> do+        { let entry = entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg+        ; emit $ mkJump dflags NativeNodeCall entry+                        [cmmUntag dflags fun] updfr_off+        ; return AssignedDirectly+        }++      -- The result will be scrutinised in the sequel.  This is where+      -- we generate a tag-test to avoid entering the closure if+      -- possible.+      --+      -- The generated code will be something like this:+      --+      --    R1 = fun  -- copyout+      --    if (fun & 7 != 0) goto Lret else goto Lcall+      --  Lcall:+      --    call [fun] returns to Lret+      --  Lret:+      --    fun' = R1  -- copyin+      --    ...+      --+      -- Note in particular that the label Lret is used as a+      -- destination by both the tag-test and the call.  This is+      -- because Lret will necessarily be a proc-point, and we want to+      -- ensure that we generate only one proc-point for this+      -- sequence.+      --+      -- Furthermore, we tell the caller that we generated a native+      -- return continuation by returning (ReturnedTo Lret off), so+      -- that the continuation can be reused by the heap-check failure+      -- code in the enclosing case expression.+      --+      AssignTo res_regs _ -> do+       { lret <- newBlockId+       ; let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs []+       ; lcall <- newBlockId+       ; updfr_off <- getUpdFrameOff+       ; let area = Young lret+       ; let (outArgs, regs, copyout) = copyOutOflow dflags NativeNodeCall Call area+                                          [fun] updfr_off []+         -- refer to fun via nodeReg after the copyout, to avoid having+         -- both live simultaneously; this sometimes enables fun to be+         -- inlined in the RHS of the R1 assignment.+       ; let entry = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg))+             the_call = toCall entry (Just lret) updfr_off off outArgs regs+       ; tscope <- getTickScope+       ; emit $+           copyout <*>+           mkCbranch (cmmIsTagged dflags (CmmReg nodeReg))+                     lret lcall Nothing <*>+           outOfLine lcall (the_call,tscope) <*>+           mkLabel lret tscope <*>+           copyin+       ; return (ReturnedTo lret off)+       }+  }++------------------------------------------------------------------------+--              Ticks+------------------------------------------------------------------------++-- | Generate Cmm code for a tick. Depending on the type of Tickish,+-- this will either generate actual Cmm instrumentation code, or+-- simply pass on the annotation as a @CmmTickish@.+cgTick :: Tickish Id -> FCode ()+cgTick tick+  = do { dflags <- getDynFlags+       ; case tick of+           ProfNote   cc t p -> emitSetCCC cc t p+           HpcTick    m n    -> emit (mkTickBox dflags m n)+           SourceNote s n    -> emitTick $ SourceNote s n+           _other            -> return () -- ignore+       }
+ compiler/GHC/StgToCmm/ExtCode.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE DeriveFunctor #-}+-- | Our extended FCode monad.++-- We add a mapping from names to CmmExpr, to support local variable names in+-- the concrete C-- code.  The unique supply of the underlying FCode monad+-- is used to grab a new unique for each local variable.++-- In C--, a local variable can be declared anywhere within a proc,+-- and it scopes from the beginning of the proc to the end.  Hence, we have+-- to collect declarations as we parse the proc, and feed the environment+-- back in circularly (to avoid a two-pass algorithm).++module GHC.StgToCmm.ExtCode (+        CmmParse, unEC,+        Named(..), Env,++        loopDecls,+        getEnv,++        withName,+        getName,++        newLocal,+        newLabel,+        newBlockId,+        newFunctionName,+        newImport,+        lookupLabel,+        lookupName,++        code,+        emit, emitLabel, emitAssign, emitStore,+        getCode, getCodeR, getCodeScoped,+        emitOutOfLine,+        withUpdFrameOff, getUpdFrameOff+)++where++import GhcPrelude++import qualified GHC.StgToCmm.Monad as F+import GHC.StgToCmm.Monad (FCode, newUnique)++import Cmm+import CLabel+import MkGraph++import BlockId+import DynFlags+import FastString+import Module+import UniqFM+import Unique+import UniqSupply++import Control.Monad (ap)++-- | The environment contains variable definitions or blockids.+data Named+        = VarN CmmExpr          -- ^ Holds CmmLit(CmmLabel ..) which gives the label type,+                                --      eg, RtsLabel, ForeignLabel, CmmLabel etc.++        | FunN   UnitId      -- ^ A function name from this package+        | LabelN BlockId                -- ^ A blockid of some code or data.++-- | An environment of named things.+type Env        = UniqFM Named++-- | Local declarations that are in scope during code generation.+type Decls      = [(FastString,Named)]++-- | Does a computation in the FCode monad, with a current environment+--      and a list of local declarations. Returns the resulting list of declarations.+newtype CmmParse a+        = EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) }+    deriving (Functor)++type ExtCode = CmmParse ()++returnExtFC :: a -> CmmParse a+returnExtFC a   = EC $ \_ _ s -> return (s, a)++thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b+thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s'++instance Applicative CmmParse where+      pure = returnExtFC+      (<*>) = ap++instance Monad CmmParse where+  (>>=) = thenExtFC++instance MonadUnique CmmParse where+  getUniqueSupplyM = code getUniqueSupplyM+  getUniqueM = EC $ \_ _ decls -> do+    u <- getUniqueM+    return (decls, u)++instance HasDynFlags CmmParse where+    getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags+                                   return (d, dflags))+++-- | Takes the variable decarations and imports from the monad+--      and makes an environment, which is looped back into the computation.+--      In this way, we can have embedded declarations that scope over the whole+--      procedure, and imports that scope over the entire module.+--      Discards the local declaration contained within decl'+--+loopDecls :: CmmParse a -> CmmParse a+loopDecls (EC fcode) =+      EC $ \c e globalDecls -> do+        (_, a) <- F.fixC $ \ ~(decls, _) ->+          fcode c (addListToUFM e decls) globalDecls+        return (globalDecls, a)+++-- | Get the current environment from the monad.+getEnv :: CmmParse Env+getEnv  = EC $ \_ e s -> return (s, e)++-- | Get the current context name from the monad+getName :: CmmParse String+getName  = EC $ \c _ s -> return (s, c)++-- | Set context name for a sub-parse+withName :: String -> CmmParse a -> CmmParse a+withName c' (EC fcode) = EC $ \_ e s -> fcode c' e s++addDecl :: FastString -> Named -> ExtCode+addDecl name named = EC $ \_ _ s -> return ((name, named) : s, ())+++-- | Add a new variable to the list of local declarations.+--      The CmmExpr says where the value is stored.+addVarDecl :: FastString -> CmmExpr -> ExtCode+addVarDecl var expr = addDecl var (VarN expr)++-- | Add a new label to the list of local declarations.+addLabel :: FastString -> BlockId -> ExtCode+addLabel name block_id = addDecl name (LabelN block_id)+++-- | Create a fresh local variable of a given type.+newLocal+        :: CmmType              -- ^ data type+        -> FastString           -- ^ name of variable+        -> CmmParse LocalReg    -- ^ register holding the value++newLocal ty name = do+   u <- code newUnique+   let reg = LocalReg u ty+   addVarDecl name (CmmReg (CmmLocal reg))+   return reg+++-- | Allocate a fresh label.+newLabel :: FastString -> CmmParse BlockId+newLabel name = do+   u <- code newUnique+   addLabel name (mkBlockId u)+   return (mkBlockId u)++-- | Add add a local function to the environment.+newFunctionName+        :: FastString   -- ^ name of the function+        -> UnitId    -- ^ package of the current module+        -> ExtCode++newFunctionName name pkg = addDecl name (FunN pkg)+++-- | Add an imported foreign label to the list of local declarations.+--      If this is done at the start of the module the declaration will scope+--      over the whole module.+newImport+        :: (FastString, CLabel)+        -> CmmParse ()++newImport (name, cmmLabel)+   = addVarDecl name (CmmLit (CmmLabel cmmLabel))+++-- | Lookup the BlockId bound to the label with this name.+--      If one hasn't been bound yet, create a fresh one based on the+--      Unique of the name.+lookupLabel :: FastString -> CmmParse BlockId+lookupLabel name = do+  env <- getEnv+  return $+     case lookupUFM env name of+        Just (LabelN l) -> l+        _other          -> mkBlockId (newTagUnique (getUnique name) 'L')+++-- | Lookup the location of a named variable.+--      Unknown names are treated as if they had been 'import'ed from the runtime system.+--      This saves us a lot of bother in the RTS sources, at the expense of+--      deferring some errors to link time.+lookupName :: FastString -> CmmParse CmmExpr+lookupName name = do+  env    <- getEnv+  return $+     case lookupUFM env name of+        Just (VarN e)   -> e+        Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg          name))+        _other          -> CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId name))+++-- | Lift an FCode computation into the CmmParse monad+code :: FCode a -> CmmParse a+code fc = EC $ \_ _ s -> do+                r <- fc+                return (s, r)++emit :: CmmAGraph -> CmmParse ()+emit = code . F.emit++emitLabel :: BlockId -> CmmParse ()+emitLabel = code . F.emitLabel++emitAssign :: CmmReg  -> CmmExpr -> CmmParse ()+emitAssign l r = code (F.emitAssign l r)++emitStore :: CmmExpr  -> CmmExpr -> CmmParse ()+emitStore l r = code (F.emitStore l r)++getCode :: CmmParse a -> CmmParse CmmAGraph+getCode (EC ec) = EC $ \c e s -> do+  ((s',_), gr) <- F.getCodeR (ec c e s)+  return (s', gr)++getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)+getCodeR (EC ec) = EC $ \c e s -> do+  ((s', r), gr) <- F.getCodeR (ec c e s)+  return (s', (r,gr))++getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped)+getCodeScoped (EC ec) = EC $ \c e s -> do+  ((s', r), gr) <- F.getCodeScoped (ec c e s)+  return (s', (r,gr))++emitOutOfLine :: BlockId -> CmmAGraphScoped -> CmmParse ()+emitOutOfLine l g = code (F.emitOutOfLine l g)++withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()+withUpdFrameOff size inner+  = EC $ \c e s -> F.withUpdFrameOff size $ (unEC inner) c e s++getUpdFrameOff :: CmmParse UpdFrameOffset+getUpdFrameOff = code $ F.getUpdFrameOff
+ compiler/GHC/StgToCmm/Foreign.hs view
@@ -0,0 +1,627 @@+-----------------------------------------------------------------------------+--+-- Code generation for foreign calls.+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Foreign (+  cgForeignCall,+  emitPrimCall, emitCCall,+  emitForeignCall,     -- For CmmParse+  emitSaveThreadState,+  saveThreadState,+  emitLoadThreadState,+  loadThreadState,+  emitOpenNursery,+  emitCloseNursery,+ ) where++import GhcPrelude hiding( succ, (<*>) )++import StgSyn+import GHC.StgToCmm.Prof (storeCurCCS, ccsType)+import GHC.StgToCmm.Env+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Closure+import GHC.StgToCmm.Layout++import BlockId (newBlockId)+import Cmm+import CmmUtils+import MkGraph+import Type+import RepType+import CLabel+import SMRep+import ForeignCall+import DynFlags+import Maybes+import Outputable+import UniqSupply+import BasicTypes++import TyCoRep+import TysPrim+import Util (zipEqual)++import Control.Monad++-----------------------------------------------------------------------------+-- Code generation for Foreign Calls+-----------------------------------------------------------------------------++-- | Emit code for a foreign call, and return the results to the sequel.+-- Precondition: the length of the arguments list is the same as the+-- arity of the foreign function.+cgForeignCall :: ForeignCall            -- the op+              -> Type                   -- type of foreign function+              -> [StgArg]               -- x,y    arguments+              -> Type                   -- result type+              -> FCode ReturnKind++cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty+  = do  { dflags <- getDynFlags+        ; let -- in the stdcall calling convention, the symbol needs @size appended+              -- to it, where size is the total number of bytes of arguments.  We+              -- attach this info to the CLabel here, and the CLabel pretty printer+              -- will generate the suffix when the label is printed.+            call_size args+              | StdCallConv <- cconv = Just (sum (map arg_size args))+              | otherwise            = Nothing++              -- ToDo: this might not be correct for 64-bit API+            arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType dflags arg)+                                     (wORD_SIZE dflags)+        ; cmm_args <- getFCallArgs stg_args typ+        ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty+        ; let ((call_args, arg_hints), cmm_target)+                = case target of+                   StaticTarget _ _   _      False ->+                       panic "cgForeignCall: unexpected FFI value import"+                   StaticTarget _ lbl mPkgId True+                     -> let labelSource+                                = case mPkgId of+                                        Nothing         -> ForeignLabelInThisPackage+                                        Just pkgId      -> ForeignLabelInPackage pkgId+                            size = call_size cmm_args+                        in  ( unzip cmm_args+                            , CmmLit (CmmLabel+                                        (mkForeignLabel lbl size labelSource IsFunction)))++                   DynamicTarget    ->  case cmm_args of+                                           (fn,_):rest -> (unzip rest, fn)+                                           [] -> panic "cgForeignCall []"+              fc = ForeignConvention cconv arg_hints res_hints CmmMayReturn+              call_target = ForeignTarget cmm_target fc++        -- we want to emit code for the call, and then emitReturn.+        -- However, if the sequel is AssignTo, we shortcut a little+        -- and generate a foreign call that assigns the results+        -- directly.  Otherwise we end up generating a bunch of+        -- useless "r = r" assignments, which are not merely annoying:+        -- they prevent the common block elimination from working correctly+        -- in the case of a safe foreign call.+        -- See Note [safe foreign call convention]+        --+        ; sequel <- getSequel+        ; case sequel of+            AssignTo assign_to_these _ ->+                emitForeignCall safety assign_to_these call_target call_args++            _something_else ->+                do { _ <- emitForeignCall safety res_regs call_target call_args+                   ; emitReturn (map (CmmReg . CmmLocal) res_regs)+                   }+         }++{- Note [safe foreign call convention]++The simple thing to do for a safe foreign call would be the same as an+unsafe one: just++    emitForeignCall ...+    emitReturn ...++but consider what happens in this case++   case foo x y z of+     (# s, r #) -> ...++The sequel is AssignTo [r].  The call to newUnboxedTupleRegs picks [r]+as the result reg, and we generate++  r = foo(x,y,z) returns to L1  -- emitForeignCall+ L1:+  r = r  -- emitReturn+  goto L2+L2:+  ...++Now L1 is a proc point (by definition, it is the continuation of the+safe foreign call).  If L2 does a heap check, then L2 will also be a+proc point.++Furthermore, the stack layout algorithm has to arrange to save r+somewhere between the call and the jump to L1, which is annoying: we+would have to treat r differently from the other live variables, which+have to be saved *before* the call.++So we adopt a special convention for safe foreign calls: the results+are copied out according to the NativeReturn convention by the call,+and the continuation of the call should copyIn the results.  (The+copyOut code is actually inserted when the safe foreign call is+lowered later).  The result regs attached to the safe foreign call are+only used temporarily to hold the results before they are copied out.++We will now generate this:++  r = foo(x,y,z) returns to L1+ L1:+  r = R1  -- copyIn, inserted by mkSafeCall+  goto L2+ L2:+  ... r ...++And when the safe foreign call is lowered later (see Note [lower safe+foreign calls]) we get this:++  suspendThread()+  r = foo(x,y,z)+  resumeThread()+  R1 = r  -- copyOut, inserted by lowerSafeForeignCall+  jump L1+ L1:+  r = R1  -- copyIn, inserted by mkSafeCall+  goto L2+ L2:+  ... r ...++Now consider what happens if L2 does a heap check: the Adams+optimisation kicks in and commons up L1 with the heap-check+continuation, resulting in just one proc point instead of two. Yay!+-}+++emitCCall :: [(CmmFormal,ForeignHint)]+          -> CmmExpr+          -> [(CmmActual,ForeignHint)]+          -> FCode ()+emitCCall hinted_results fn hinted_args+  = void $ emitForeignCall PlayRisky results target args+  where+    (args, arg_hints) = unzip hinted_args+    (results, result_hints) = unzip hinted_results+    target = ForeignTarget fn fc+    fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn+++emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()+emitPrimCall res op args+  = void $ emitForeignCall PlayRisky res (PrimTarget op) args++-- alternative entry point, used by CmmParse+emitForeignCall+        :: Safety+        -> [CmmFormal]          -- where to put the results+        -> ForeignTarget        -- the op+        -> [CmmActual]          -- arguments+        -> FCode ReturnKind+emitForeignCall safety results target args+  | not (playSafe safety) = do+    dflags <- getDynFlags+    let (caller_save, caller_load) = callerSaveVolatileRegs dflags+    emit caller_save+    target' <- load_target_into_temp target+    args' <- mapM maybe_assign_temp args+    emit $ mkUnsafeCall target' results args'+    emit caller_load+    return AssignedDirectly++  | otherwise = do+    dflags <- getDynFlags+    updfr_off <- getUpdFrameOff+    target' <- load_target_into_temp target+    args' <- mapM maybe_assign_temp args+    k <- newBlockId+    let (off, _, copyout) = copyInOflow dflags NativeReturn (Young k) results []+       -- see Note [safe foreign call convention]+    tscope <- getTickScope+    emit $+           (    mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags)))+                        (CmmLit (CmmBlock k))+            <*> mkLast (CmmForeignCall { tgt  = target'+                                       , res  = results+                                       , args = args'+                                       , succ = k+                                       , ret_args = off+                                       , ret_off = updfr_off+                                       , intrbl = playInterruptible safety })+            <*> mkLabel k tscope+            <*> copyout+           )+    return (ReturnedTo k off)++load_target_into_temp :: ForeignTarget -> FCode ForeignTarget+load_target_into_temp (ForeignTarget expr conv) = do+  tmp <- maybe_assign_temp expr+  return (ForeignTarget tmp conv)+load_target_into_temp other_target@(PrimTarget _) =+  return other_target++-- What we want to do here is create a new temporary for the foreign+-- call argument if it is not safe to use the expression directly,+-- because the expression mentions caller-saves GlobalRegs (see+-- Note [Register Parameter Passing]).+--+-- However, we can't pattern-match on the expression here, because+-- this is used in a loop by CmmParse, and testing the expression+-- results in a black hole.  So we always create a temporary, and rely+-- on CmmSink to clean it up later.  (Yuck, ToDo).  The generated code+-- ends up being the same, at least for the RTS .cmm code.+--+maybe_assign_temp :: CmmExpr -> FCode CmmExpr+maybe_assign_temp e = do+  dflags <- getDynFlags+  reg <- newTemp (cmmExprType dflags e)+  emitAssign (CmmLocal reg) e+  return (CmmReg (CmmLocal reg))++-- -----------------------------------------------------------------------------+-- Save/restore the thread state in the TSO++-- This stuff can't be done in suspendThread/resumeThread, because it+-- refers to global registers which aren't available in the C world.++emitSaveThreadState :: FCode ()+emitSaveThreadState = do+  dflags <- getDynFlags+  code <- saveThreadState dflags+  emit code++-- | Produce code to save the current thread state to @CurrentTSO@+saveThreadState :: MonadUnique m => DynFlags -> m CmmAGraph+saveThreadState dflags = do+  tso <- newTemp (gcWord dflags)+  close_nursery <- closeNursery dflags tso+  pure $ catAGraphs [+    -- tso = CurrentTSO;+    mkAssign (CmmLocal tso) currentTSOExpr,+    -- tso->stackobj->sp = Sp;+    mkStore (cmmOffset dflags+                       (CmmLoad (cmmOffset dflags+                                           (CmmReg (CmmLocal tso))+                                           (tso_stackobj dflags))+                                (bWord dflags))+                       (stack_SP dflags))+            spExpr,+    close_nursery,+    -- and save the current cost centre stack in the TSO when profiling:+    if gopt Opt_SccProfilingOn dflags then+        mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr+      else mkNop+    ]++emitCloseNursery :: FCode ()+emitCloseNursery = do+  dflags <- getDynFlags+  tso <- newTemp (bWord dflags)+  code <- closeNursery dflags tso+  emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code++{- |+@closeNursery dflags tso@ produces code to close the nursery.+A local register holding the value of @CurrentTSO@ is expected for+efficiency.++Closing the nursery corresponds to the following code:++@+  tso = CurrentTSO;+  cn = CurrentNuresry;++  // Update the allocation limit for the current thread.  We don't+  // check to see whether it has overflowed at this point, that check is+  // made when we run out of space in the current heap block (stg_gc_noregs)+  // and in the scheduler when context switching (schedulePostRunThread).+  tso->alloc_limit -= Hp + WDS(1) - cn->start;++  // Set cn->free to the next unoccupied word in the block+  cn->free = Hp + WDS(1);+@+-}+closeNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph+closeNursery df tso = do+  let tsoreg  = CmmLocal tso+  cnreg      <- CmmLocal <$> newTemp (bWord df)+  pure $ catAGraphs [+    mkAssign cnreg currentNurseryExpr,++    -- CurrentNursery->free = Hp+1;+    mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df hpExpr 1),++    let alloc =+           CmmMachOp (mo_wordSub df)+              [ cmmOffsetW df hpExpr 1+              , CmmLoad (nursery_bdescr_start df cnreg) (bWord df)+              ]++        alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)+    in++    -- tso->alloc_limit += alloc+    mkStore alloc_limit (CmmMachOp (MO_Sub W64)+                               [ CmmLoad alloc_limit b64+                               , CmmMachOp (mo_WordTo64 df) [alloc] ])+   ]++emitLoadThreadState :: FCode ()+emitLoadThreadState = do+  dflags <- getDynFlags+  code <- loadThreadState dflags+  emit code++-- | Produce code to load the current thread state from @CurrentTSO@+loadThreadState :: MonadUnique m => DynFlags -> m CmmAGraph+loadThreadState dflags = do+  tso <- newTemp (gcWord dflags)+  stack <- newTemp (gcWord dflags)+  open_nursery <- openNursery dflags tso+  pure $ catAGraphs [+    -- tso = CurrentTSO;+    mkAssign (CmmLocal tso) currentTSOExpr,+    -- stack = tso->stackobj;+    mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)),+    -- Sp = stack->sp;+    mkAssign spReg (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)),+    -- SpLim = stack->stack + RESERVED_STACK_WORDS;+    mkAssign spLimReg (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))+                                (rESERVED_STACK_WORDS dflags)),+    -- HpAlloc = 0;+    --   HpAlloc is assumed to be set to non-zero only by a failed+    --   a heap check, see HeapStackCheck.cmm:GC_GENERIC+    mkAssign hpAllocReg (zeroExpr dflags),+    open_nursery,+    -- and load the current cost centre stack from the TSO when profiling:+    if gopt Opt_SccProfilingOn dflags+       then storeCurCCS+              (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso))+                 (tso_CCCS dflags)) (ccsType dflags))+       else mkNop+   ]+++emitOpenNursery :: FCode ()+emitOpenNursery = do+  dflags <- getDynFlags+  tso <- newTemp (bWord dflags)+  code <- openNursery dflags tso+  emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code++{- |+@openNursery dflags tso@ produces code to open the nursery. A local register+holding the value of @CurrentTSO@ is expected for efficiency.++Opening the nursery corresponds to the following code:++@+   tso = CurrentTSO;+   cn = CurrentNursery;+   bdfree = CurrentNursery->free;+   bdstart = CurrentNursery->start;++   // We *add* the currently occupied portion of the nursery block to+   // the allocation limit, because we will subtract it again in+   // closeNursery.+   tso->alloc_limit += bdfree - bdstart;++   // Set Hp to the last occupied word of the heap block.  Why not the+   // next unocupied word?  Doing it this way means that we get to use+   // an offset of zero more often, which might lead to slightly smaller+   // code on some architectures.+   Hp = bdfree - WDS(1);++   // Set HpLim to the end of the current nursery block (note that this block+   // might be a block group, consisting of several adjacent blocks.+   HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1;+@+-}+openNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph+openNursery df tso = do+  let tsoreg =  CmmLocal tso+  cnreg      <- CmmLocal <$> newTemp (bWord df)+  bdfreereg  <- CmmLocal <$> newTemp (bWord df)+  bdstartreg <- CmmLocal <$> newTemp (bWord df)++  -- These assignments are carefully ordered to reduce register+  -- pressure and generate not completely awful code on x86.  To see+  -- what code we generate, look at the assembly for+  -- stg_returnToStackTop in rts/StgStartup.cmm.+  pure $ catAGraphs [+     mkAssign cnreg currentNurseryExpr,+     mkAssign bdfreereg  (CmmLoad (nursery_bdescr_free df cnreg)  (bWord df)),++     -- Hp = CurrentNursery->free - 1;+     mkAssign hpReg (cmmOffsetW df (CmmReg bdfreereg) (-1)),++     mkAssign bdstartreg (CmmLoad (nursery_bdescr_start df cnreg) (bWord df)),++     -- HpLim = CurrentNursery->start ++     --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;+     mkAssign hpLimReg+         (cmmOffsetExpr df+             (CmmReg bdstartreg)+             (cmmOffset df+               (CmmMachOp (mo_wordMul df) [+                 CmmMachOp (MO_SS_Conv W32 (wordWidth df))+                   [CmmLoad (nursery_bdescr_blocks df cnreg) b32],+                 mkIntExpr df (bLOCK_SIZE df)+                ])+               (-1)+             )+         ),++     -- alloc = bd->free - bd->start+     let alloc =+           CmmMachOp (mo_wordSub df) [CmmReg bdfreereg, CmmReg bdstartreg]++         alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)+     in++     -- tso->alloc_limit += alloc+     mkStore alloc_limit (CmmMachOp (MO_Add W64)+                               [ CmmLoad alloc_limit b64+                               , CmmMachOp (mo_WordTo64 df) [alloc] ])++   ]++nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks+  :: DynFlags -> CmmReg -> CmmExpr+nursery_bdescr_free   dflags cn =+  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_free dflags)+nursery_bdescr_start  dflags cn =+  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_start dflags)+nursery_bdescr_blocks dflags cn =+  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_blocks dflags)++tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff+tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags)+tso_alloc_limit dflags = closureField dflags (oFFSET_StgTSO_alloc_limit dflags)+tso_CCCS     dflags = closureField dflags (oFFSET_StgTSO_cccs dflags)+stack_STACK  dflags = closureField dflags (oFFSET_StgStack_stack dflags)+stack_SP     dflags = closureField dflags (oFFSET_StgStack_sp dflags)+++closureField :: DynFlags -> ByteOff -> ByteOff+closureField dflags off = off + fixedHdrSize dflags++-- Note [Unlifted boxed arguments to foreign calls]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- For certain types passed to foreign calls, we adjust the actual+-- value passed to the call.  For ByteArray#, Array#, SmallArray#,+-- and ArrayArray#, we pass the address of the array's payload, not+-- the address of the heap object. For example, consider+--   foreign import "c_foo" foo :: ByteArray# -> Int# -> IO ()+-- At a Haskell call like `foo x y`, we'll generate a C call that+-- is more like+--   c_foo( x+8, y )+-- where the "+8" takes the heap pointer (x :: ByteArray#) and moves+-- it past the header words of the ByteArray object to point directly+-- to the data inside the ByteArray#. (The exact offset depends+-- on the target architecture and on profiling) By contrast, (y :: Int#)+-- requires no such adjustment.+--+-- This adjustment is performed by 'add_shim'. The size of the+-- adjustment depends on the type of heap object. But+-- how can we determine that type? There are two available options.+-- We could use the types of the actual values that the foreign call+-- has been applied to, or we could use the types present in the+-- foreign function's type. Prior to GHC 8.10, we used the former+-- strategy since it's a little more simple. However, in issue #16650+-- and more compellingly in the comments of+-- https://gitlab.haskell.org/ghc/ghc/merge_requests/939, it was+-- demonstrated that this leads to bad behavior in the presence+-- of unsafeCoerce#. Returning to the above example, suppose the+-- Haskell call looked like+--   foo (unsafeCoerce# p)+-- where the types of expressions comprising the arguments are+--   p :: (Any :: TYPE 'UnliftedRep)+--   i :: Int#+-- so that the unsafe-coerce is between Any and ByteArray#.+-- These two types have the same kind (they are both represented by+-- a heap pointer) so no GC errors will occur if we do this unsafe coerce.+-- By the time this gets to the code generator the cast has been+-- discarded so we have+--   foo p y+-- But we *must* adjust the pointer to p by a ByteArray# shim,+-- *not* by an Any shim (the Any shim involves no offset at all).+--+-- To avoid this bad behavior, we adopt the second strategy: use+-- the types present in the foreign function's type.+-- In collectStgFArgTypes, we convert the foreign function's+-- type to a list of StgFArgType. Then, in add_shim, we interpret+-- these as numeric offsets.++getFCallArgs ::+     [StgArg]+  -> Type -- the type of the foreign function+  -> FCode [(CmmExpr, ForeignHint)]+-- (a) Drop void args+-- (b) Add foreign-call shim code+-- It's (b) that makes this differ from getNonVoidArgAmodes+-- Precondition: args and typs have the same length+-- See Note [Unlifted boxed arguments to foreign calls]+getFCallArgs args typ+  = do  { mb_cmms <- mapM get (zipEqual "getFCallArgs" args (collectStgFArgTypes typ))+        ; return (catMaybes mb_cmms) }+  where+    get (arg,typ)+      | null arg_reps+      = return Nothing+      | otherwise+      = do { cmm <- getArgAmode (NonVoid arg)+           ; dflags <- getDynFlags+           ; return (Just (add_shim dflags typ cmm, hint)) }+      where+        arg_ty   = stgArgType arg+        arg_reps = typePrimRep arg_ty+        hint     = typeForeignHint arg_ty++-- The minimum amount of information needed to determine+-- the offset to apply to an argument to a foreign call.+-- See Note [Unlifted boxed arguments to foreign calls]+data StgFArgType+  = StgPlainType+  | StgArrayType+  | StgSmallArrayType+  | StgByteArrayType++-- See Note [Unlifted boxed arguments to foreign calls]+add_shim :: DynFlags -> StgFArgType -> CmmExpr -> CmmExpr+add_shim dflags ty expr = case ty of+  StgPlainType -> expr+  StgArrayType -> cmmOffsetB dflags expr (arrPtrsHdrSize dflags)+  StgSmallArrayType -> cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags)+  StgByteArrayType -> cmmOffsetB dflags expr (arrWordsHdrSize dflags)++-- From a function, extract information needed to determine+-- the offset of each argument when used as a C FFI argument.+-- See Note [Unlifted boxed arguments to foreign calls]+collectStgFArgTypes :: Type -> [StgFArgType]+collectStgFArgTypes = go []+  where+    -- Skip foralls+    go bs (ForAllTy _ res) = go bs res+    go bs (AppTy{}) = reverse bs+    go bs (TyConApp{}) = reverse bs+    go bs (LitTy{}) = reverse bs+    go bs (TyVarTy{}) = reverse bs+    go  _ (CastTy{}) = panic "myCollectTypeArgs: CastTy"+    go  _ (CoercionTy{}) = panic "myCollectTypeArgs: CoercionTy"+    go bs (FunTy {ft_arg = arg, ft_res=res}) =+      go (typeToStgFArgType arg:bs) res++-- Choose the offset based on the type. For anything other+-- than an unlifted boxed type, there is no offset.+-- See Note [Unlifted boxed arguments to foreign calls]+typeToStgFArgType :: Type -> StgFArgType+typeToStgFArgType typ+  | tycon == arrayPrimTyCon = StgArrayType+  | tycon == mutableArrayPrimTyCon = StgArrayType+  | tycon == arrayArrayPrimTyCon = StgArrayType+  | tycon == mutableArrayArrayPrimTyCon = StgArrayType+  | tycon == smallArrayPrimTyCon = StgSmallArrayType+  | tycon == smallMutableArrayPrimTyCon = StgSmallArrayType+  | tycon == byteArrayPrimTyCon = StgByteArrayType+  | tycon == mutableByteArrayPrimTyCon = StgByteArrayType+  | otherwise = StgPlainType+  where+  -- Should be a tycon app, since this is a foreign call. We look+  -- through newtypes so the offset does not change if a user replaces+  -- a type in a foreign function signature with a representationally+  -- equivalent newtype.+  tycon = tyConAppTyCon (unwrapType typ)+
+ compiler/GHC/StgToCmm/Heap.hs view
@@ -0,0 +1,680 @@+-----------------------------------------------------------------------------+--+-- Stg to C--: heap management functions+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Heap (+        getVirtHp, setVirtHp, setRealHp,+        getHpRelOffset,++        entryHeapCheck, altHeapCheck, noEscapeHeapCheck, altHeapCheckReturnsTo,+        heapStackCheckGen,+        entryHeapCheck',++        mkStaticClosureFields, mkStaticClosure,++        allocDynClosure, allocDynClosureCmm, allocHeapClosure,+        emitSetDynHdr+    ) where++import GhcPrelude hiding ((<*>))++import StgSyn+import CLabel+import GHC.StgToCmm.Layout+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Prof (profDynAlloc, dynProfHdr, staticProfHdr)+import GHC.StgToCmm.Ticky+import GHC.StgToCmm.Closure+import GHC.StgToCmm.Env++import MkGraph++import Hoopl.Label+import SMRep+import BlockId+import Cmm+import CmmUtils+import CostCentre+import IdInfo( CafInfo(..), mayHaveCafRefs )+import Id ( Id )+import Module+import DynFlags+import FastString( mkFastString, fsLit )+import Panic( sorry )++import Control.Monad (when)+import Data.Maybe (isJust)++-----------------------------------------------------------+--              Initialise dynamic heap objects+-----------------------------------------------------------++allocDynClosure+        :: Maybe Id+        -> CmmInfoTable+        -> LambdaFormInfo+        -> CmmExpr              -- Cost Centre to stick in the object+        -> CmmExpr              -- Cost Centre to blame for this alloc+                                -- (usually the same; sometimes "OVERHEAD")++        -> [(NonVoid StgArg, VirtualHpOffset)]  -- Offsets from start of object+                                                -- ie Info ptr has offset zero.+                                                -- No void args in here+        -> FCode CmmExpr -- returns Hp+n++allocDynClosureCmm+        :: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr+        -> [(CmmExpr, ByteOff)]+        -> FCode CmmExpr -- returns Hp+n++-- allocDynClosure allocates the thing in the heap,+-- and modifies the virtual Hp to account for this.+-- The second return value is the graph that sets the value of the+-- returned LocalReg, which should point to the closure after executing+-- the graph.++-- allocDynClosure returns an (Hp+8) CmmExpr, and hence the result is+-- only valid until Hp is changed.  The caller should assign the+-- result to a LocalReg if it is required to remain live.+--+-- The reason we don't assign it to a LocalReg here is that the caller+-- is often about to call regIdInfo, which immediately assigns the+-- result of allocDynClosure to a new temp in order to add the tag.+-- So by not generating a LocalReg here we avoid a common source of+-- new temporaries and save some compile time.  This can be quite+-- significant - see test T4801.+++allocDynClosure mb_id info_tbl lf_info use_cc _blame_cc args_w_offsets = do+  let (args, offsets) = unzip args_w_offsets+  cmm_args <- mapM getArgAmode args     -- No void args+  allocDynClosureCmm mb_id info_tbl lf_info+                     use_cc _blame_cc (zip cmm_args offsets)+++allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc amodes_w_offsets = do+  -- SAY WHAT WE ARE ABOUT TO DO+  let rep = cit_rep info_tbl+  tickyDynAlloc mb_id rep lf_info+  let info_ptr = CmmLit (CmmLabel (cit_lbl info_tbl))+  allocHeapClosure rep info_ptr use_cc amodes_w_offsets+++-- | Low-level heap object allocation.+allocHeapClosure+  :: SMRep                            -- ^ representation of the object+  -> CmmExpr                          -- ^ info pointer+  -> CmmExpr                          -- ^ cost centre+  -> [(CmmExpr,ByteOff)]              -- ^ payload+  -> FCode CmmExpr                    -- ^ returns the address of the object+allocHeapClosure rep info_ptr use_cc payload = do+  profDynAlloc rep use_cc++  virt_hp <- getVirtHp++  -- Find the offset of the info-ptr word+  let info_offset = virt_hp + 1+            -- info_offset is the VirtualHpOffset of the first+            -- word of the new object+            -- Remember, virtHp points to last allocated word,+            -- ie 1 *before* the info-ptr word of new object.++  base <- getHpRelOffset info_offset+  emitComment $ mkFastString "allocHeapClosure"+  emitSetDynHdr base info_ptr use_cc++  -- Fill in the fields+  hpStore base payload++  -- Bump the virtual heap pointer+  dflags <- getDynFlags+  setVirtHp (virt_hp + heapClosureSizeW dflags rep)++  return base+++emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()+emitSetDynHdr base info_ptr ccs+  = do dflags <- getDynFlags+       hpStore base (zip (header dflags) [0, wORD_SIZE dflags ..])+  where+    header :: DynFlags -> [CmmExpr]+    header dflags = [info_ptr] ++ dynProfHdr dflags ccs+        -- ToDo: Parallel stuff+        -- No ticky header++-- Store the item (expr,off) in base[off]+hpStore :: CmmExpr -> [(CmmExpr, ByteOff)] -> FCode ()+hpStore base vals = do+  dflags <- getDynFlags+  sequence_ $+    [ emitStore (cmmOffsetB dflags base off) val | (val,off) <- vals ]++-----------------------------------------------------------+--              Layout of static closures+-----------------------------------------------------------++-- Make a static closure, adding on any extra padding needed for CAFs,+-- and adding a static link field if necessary.++mkStaticClosureFields+        :: DynFlags+        -> CmmInfoTable+        -> CostCentreStack+        -> CafInfo+        -> [CmmLit]             -- Payload+        -> [CmmLit]             -- The full closure+mkStaticClosureFields dflags info_tbl ccs caf_refs payload+  = mkStaticClosure dflags info_lbl ccs payload padding+        static_link_field saved_info_field+  where+    info_lbl = cit_lbl info_tbl++    -- CAFs must have consistent layout, regardless of whether they+    -- are actually updatable or not.  The layout of a CAF is:+    --+    --        3 saved_info+    --        2 static_link+    --        1 indirectee+    --        0 info ptr+    --+    -- the static_link and saved_info fields must always be in the+    -- same place.  So we use isThunkRep rather than closureUpdReqd+    -- here:++    is_caf = isThunkRep (cit_rep info_tbl)++    padding+        | is_caf && null payload = [mkIntCLit dflags 0]+        | otherwise = []++    static_link_field+        | is_caf || staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl+        = [static_link_value]+        | otherwise+        = []++    saved_info_field+        | is_caf     = [mkIntCLit dflags 0]+        | otherwise  = []++        -- For a static constructor which has NoCafRefs, we set the+        -- static link field to a non-zero value so the garbage+        -- collector will ignore it.+    static_link_value+        | mayHaveCafRefs caf_refs  = mkIntCLit dflags 0+        | otherwise                = mkIntCLit dflags 3  -- No CAF refs+                                      -- See Note [STATIC_LINK fields]+                                      -- in rts/sm/Storage.h++mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit]+  -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]+mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field+  =  [CmmLabel info_lbl]+  ++ staticProfHdr dflags ccs+  ++ payload+  ++ padding+  ++ static_link_field+  ++ saved_info_field++-----------------------------------------------------------+--              Heap overflow checking+-----------------------------------------------------------++{- Note [Heap checks]+   ~~~~~~~~~~~~~~~~~~+Heap checks come in various forms.  We provide the following entry+points to the runtime system, all of which use the native C-- entry+convention.++  * gc() performs garbage collection and returns+    nothing to its caller++  * A series of canned entry points like+        r = gc_1p( r )+    where r is a pointer.  This performs gc, and+    then returns its argument r to its caller.++  * A series of canned entry points like+        gcfun_2p( f, x, y )+    where f is a function closure of arity 2+    This performs garbage collection, keeping alive the+    three argument ptrs, and then tail-calls f(x,y)++These are used in the following circumstances++* entryHeapCheck: Function entry+    (a) With a canned GC entry sequence+        f( f_clo, x:ptr, y:ptr ) {+             Hp = Hp+8+             if Hp > HpLim goto L+             ...+          L: HpAlloc = 8+             jump gcfun_2p( f_clo, x, y ) }+     Note the tail call to the garbage collector;+     it should do no register shuffling++    (b) No canned sequence+        f( f_clo, x:ptr, y:ptr, ...etc... ) {+          T: Hp = Hp+8+             if Hp > HpLim goto L+             ...+          L: HpAlloc = 8+             call gc()  -- Needs an info table+             goto T }++* altHeapCheck: Immediately following an eval+  Started as+        case f x y of r { (p,q) -> rhs }+  (a) With a canned sequence for the results of f+       (which is the very common case since+       all boxed cases return just one pointer+           ...+           r = f( x, y )+        K:      -- K needs an info table+           Hp = Hp+8+           if Hp > HpLim goto L+           ...code for rhs...++        L: r = gc_1p( r )+           goto K }++        Here, the info table needed by the call+        to gc_1p should be the *same* as the+        one for the call to f; the C-- optimiser+        spots this sharing opportunity)++   (b) No canned sequence for results of f+       Note second info table+           ...+           (r1,r2,r3) = call f( x, y )+        K:+           Hp = Hp+8+           if Hp > HpLim goto L+           ...code for rhs...++        L: call gc()    -- Extra info table here+           goto K++* generalHeapCheck: Anywhere else+  e.g. entry to thunk+       case branch *not* following eval,+       or let-no-escape+  Exactly the same as the previous case:++        K:      -- K needs an info table+           Hp = Hp+8+           if Hp > HpLim goto L+           ...++        L: call gc()+           goto K+-}++--------------------------------------------------------------+-- A heap/stack check at a function or thunk entry point.++entryHeapCheck :: ClosureInfo+               -> Maybe LocalReg -- Function (closure environment)+               -> Int            -- Arity -- not same as len args b/c of voids+               -> [LocalReg]     -- Non-void args (empty for thunk)+               -> FCode ()+               -> FCode ()++entryHeapCheck cl_info nodeSet arity args code+  = entryHeapCheck' is_fastf node arity args code+  where+    node = case nodeSet of+              Just r  -> CmmReg (CmmLocal r)+              Nothing -> CmmLit (CmmLabel $ staticClosureLabel cl_info)++    is_fastf = case closureFunInfo cl_info of+                 Just (_, ArgGen _) -> False+                 _otherwise         -> True++-- | lower-level version for CmmParse+entryHeapCheck' :: Bool           -- is a known function pattern+                -> CmmExpr        -- expression for the closure pointer+                -> Int            -- Arity -- not same as len args b/c of voids+                -> [LocalReg]     -- Non-void args (empty for thunk)+                -> FCode ()+                -> FCode ()+entryHeapCheck' is_fastf node arity args code+  = do dflags <- getDynFlags+       let is_thunk = arity == 0++           args' = map (CmmReg . CmmLocal) args+           stg_gc_fun    = CmmReg (CmmGlobal GCFun)+           stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)++           {- Thunks:          jump stg_gc_enter_1++              Function (fast): call (NativeNode) stg_gc_fun(fun, args)++              Function (slow): call (slow) stg_gc_fun(fun, args)+           -}+           gc_call upd+               | is_thunk+                 = mkJump dflags NativeNodeCall stg_gc_enter1 [node] upd++               | is_fastf+                 = mkJump dflags NativeNodeCall stg_gc_fun (node : args') upd++               | otherwise+                 = mkJump dflags Slow stg_gc_fun (node : args') upd++       updfr_sz <- getUpdFrameOff++       loop_id <- newBlockId+       emitLabel loop_id+       heapCheck True True (gc_call updfr_sz <*> mkBranch loop_id) code++-- ------------------------------------------------------------+-- A heap/stack check in a case alternative+++-- If there are multiple alts and we need to GC, but don't have a+-- continuation already (the scrut was simple), then we should+-- pre-generate the continuation.  (if there are multiple alts it is+-- always a canned GC point).++-- altHeapCheck:+-- If we have a return continuation,+--   then if it is a canned GC pattern,+--           then we do mkJumpReturnsTo+--           else we do a normal call to stg_gc_noregs+--   else if it is a canned GC pattern,+--           then generate the continuation and do mkCallReturnsTo+--           else we do a normal call to stg_gc_noregs++altHeapCheck :: [LocalReg] -> FCode a -> FCode a+altHeapCheck regs code = altOrNoEscapeHeapCheck False regs code++altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a+altOrNoEscapeHeapCheck checkYield regs code = do+    dflags <- getDynFlags+    case cannedGCEntryPoint dflags regs of+      Nothing -> genericGC checkYield code+      Just gc -> do+        lret <- newBlockId+        let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs []+        lcont <- newBlockId+        tscope <- getTickScope+        emitOutOfLine lret (copyin <*> mkBranch lcont, tscope)+        emitLabel lcont+        cannedGCReturnsTo checkYield False gc regs lret off code++altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a+altHeapCheckReturnsTo regs lret off code+  = do dflags <- getDynFlags+       case cannedGCEntryPoint dflags regs of+           Nothing -> genericGC False code+           Just gc -> cannedGCReturnsTo False True gc regs lret off code++-- noEscapeHeapCheck is implemented identically to altHeapCheck (which+-- is more efficient), but cannot be optimized away in the non-allocating+-- case because it may occur in a loop+noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a+noEscapeHeapCheck regs code = altOrNoEscapeHeapCheck True regs code++cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff+                  -> FCode a+                  -> FCode a+cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code+  = do dflags <- getDynFlags+       updfr_sz <- getUpdFrameOff+       heapCheck False checkYield (gc_call dflags gc updfr_sz) code+  where+    reg_exprs = map (CmmReg . CmmLocal) regs+      -- Note [stg_gc arguments]++      -- NB. we use the NativeReturn convention for passing arguments+      -- to the canned heap-check routines, because we are in a case+      -- alternative and hence the [LocalReg] was passed to us in the+      -- NativeReturn convention.+    gc_call dflags label sp+      | cont_on_stack+      = mkJumpReturnsTo dflags label NativeReturn reg_exprs lret off sp+      | otherwise+      = mkCallReturnsTo dflags label NativeReturn reg_exprs lret off sp []++genericGC :: Bool -> FCode a -> FCode a+genericGC checkYield code+  = do updfr_sz <- getUpdFrameOff+       lretry <- newBlockId+       emitLabel lretry+       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []+       heapCheck False checkYield (call <*> mkBranch lretry) code++cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr+cannedGCEntryPoint dflags regs+  = case map localRegType regs of+      []  -> Just (mkGcLabel "stg_gc_noregs")+      [ty]+          | isGcPtrType ty -> Just (mkGcLabel "stg_gc_unpt_r1")+          | isFloatType ty -> case width of+                                  W32       -> Just (mkGcLabel "stg_gc_f1")+                                  W64       -> Just (mkGcLabel "stg_gc_d1")+                                  _         -> Nothing++          | width == wordWidth dflags -> Just (mkGcLabel "stg_gc_unbx_r1")+          | width == W64              -> Just (mkGcLabel "stg_gc_l1")+          | otherwise                 -> Nothing+          where+              width = typeWidth ty+      [ty1,ty2]+          |  isGcPtrType ty1+          && isGcPtrType ty2 -> Just (mkGcLabel "stg_gc_pp")+      [ty1,ty2,ty3]+          |  isGcPtrType ty1+          && isGcPtrType ty2+          && isGcPtrType ty3 -> Just (mkGcLabel "stg_gc_ppp")+      [ty1,ty2,ty3,ty4]+          |  isGcPtrType ty1+          && isGcPtrType ty2+          && isGcPtrType ty3+          && isGcPtrType ty4 -> Just (mkGcLabel "stg_gc_pppp")+      _otherwise -> Nothing++-- Note [stg_gc arguments]+-- It might seem that we could avoid passing the arguments to the+-- stg_gc function, because they are already in the right registers.+-- While this is usually the case, it isn't always.  Sometimes the+-- code generator has cleverly avoided the eval in a case, e.g. in+-- ffi/should_run/4221.hs we found+--+--   case a_r1mb of z+--     FunPtr x y -> ...+--+-- where a_r1mb is bound a top-level constructor, and is known to be+-- evaluated.  The codegen just assigns x, y and z, and continues;+-- R1 is never assigned.+--+-- So we'll have to rely on optimisations to eliminatethese+-- assignments where possible.+++-- | The generic GC procedure; no params, no results+generic_gc :: CmmExpr+generic_gc = mkGcLabel "stg_gc_noregs"++-- | Create a CLabel for calling a garbage collector entry point+mkGcLabel :: String -> CmmExpr+mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit s)))++-------------------------------+heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a+heapCheck checkStack checkYield do_gc code+  = getHeapUsage $ \ hpHw ->+    -- Emit heap checks, but be sure to do it lazily so+    -- that the conditionals on hpHw don't cause a black hole+    do  { dflags <- getDynFlags+        ; let mb_alloc_bytes+                 | hpHw > mBLOCK_SIZE = sorry $ unlines+                    [" Trying to allocate more than "++show mBLOCK_SIZE++" bytes.",+                     "",+                     "This is currently not possible due to a limitation of GHC's code generator.",+                     "See https://gitlab.haskell.org/ghc/ghc/issues/4505 for details.",+                     "Suggestion: read data from a file instead of having large static data",+                     "structures in code."]+                 | hpHw > 0  = Just (mkIntExpr dflags (hpHw * (wORD_SIZE dflags)))+                 | otherwise = Nothing+                 where mBLOCK_SIZE = bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE_W dflags+              stk_hwm | checkStack = Just (CmmLit CmmHighStackMark)+                      | otherwise  = Nothing+        ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc+        ; tickyAllocHeap True hpHw+        ; setRealHp hpHw+        ; code }++heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode ()+heapStackCheckGen stk_hwm mb_bytes+  = do updfr_sz <- getUpdFrameOff+       lretry <- newBlockId+       emitLabel lretry+       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []+       do_checks stk_hwm False mb_bytes (call <*> mkBranch lretry)++-- Note [Single stack check]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+-- When compiling a function we can determine how much stack space it+-- will use. We therefore need to perform only a single stack check at+-- the beginning of a function to see if we have enough stack space.+--+-- The check boils down to comparing Sp-N with SpLim, where N is the+-- amount of stack space needed (see Note [Stack usage] below).  *BUT*+-- at this stage of the pipeline we are not supposed to refer to Sp+-- itself, because the stack is not yet manifest, so we don't quite+-- know where Sp pointing.++-- So instead of referring directly to Sp - as we used to do in the+-- past - the code generator uses (old + 0) in the stack check. That+-- is the address of the first word of the old area, so if we add N+-- we'll get the address of highest used word.+--+-- This makes the check robust.  For example, while we need to perform+-- only one stack check for each function, we could in theory place+-- more stack checks later in the function. They would be redundant,+-- but not incorrect (in a sense that they should not change program+-- behaviour). We need to make sure however that a stack check+-- inserted after incrementing the stack pointer checks for a+-- respectively smaller stack space. This would not be the case if the+-- code generator produced direct references to Sp. By referencing+-- (old + 0) we make sure that we always check for a correct amount of+-- stack: when converting (old + 0) to Sp the stack layout phase takes+-- into account changes already made to stack pointer. The idea for+-- this change came from observations made while debugging #8275.++-- Note [Stack usage]+-- ~~~~~~~~~~~~~~~~~~+-- At the moment we convert from STG to Cmm we don't know N, the+-- number of bytes of stack that the function will use, so we use a+-- special late-bound CmmLit, namely+--       CmmHighStackMark+-- to stand for the number of bytes needed. When the stack is made+-- manifest, the number of bytes needed is calculated, and used to+-- replace occurrences of CmmHighStackMark+--+-- The (Maybe CmmExpr) passed to do_checks is usually+--     Just (CmmLit CmmHighStackMark)+-- but can also (in certain hand-written RTS functions)+--     Just (CmmLit 8)  or some other fixed valuet+-- If it is Nothing, we don't generate a stack check at all.++do_checks :: Maybe CmmExpr    -- Should we check the stack?+                              -- See Note [Stack usage]+          -> Bool             -- Should we check for preemption?+          -> Maybe CmmExpr    -- Heap headroom (bytes)+          -> CmmAGraph        -- What to do on failure+          -> FCode ()+do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do+  dflags <- getDynFlags+  gc_id <- newBlockId++  let+    Just alloc_lit = mb_alloc_lit++    bump_hp   = cmmOffsetExprB dflags hpExpr alloc_lit++    -- Sp overflow if ((old + 0) - CmmHighStack < SpLim)+    -- At the beginning of a function old + 0 = Sp+    -- See Note [Single stack check]+    sp_oflo sp_hwm =+         CmmMachOp (mo_wordULt dflags)+                  [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg)))+                             [CmmStackSlot Old 0, sp_hwm],+                   CmmReg spLimReg]++    -- Hp overflow if (Hp > HpLim)+    -- (Hp has been incremented by now)+    -- HpLim points to the LAST WORD of valid allocation space.+    hp_oflo = CmmMachOp (mo_wordUGt dflags) [hpExpr, hpLimExpr]++    alloc_n = mkAssign hpAllocReg alloc_lit++  case mb_stk_hwm of+    Nothing -> return ()+    Just stk_hwm -> tickyStackCheck+      >> (emit =<< mkCmmIfGoto' (sp_oflo stk_hwm) gc_id (Just False) )++  -- Emit new label that might potentially be a header+  -- of a self-recursive tail call.+  -- See Note [Self-recursive loop header].+  self_loop_info <- getSelfLoop+  case self_loop_info of+    Just (_, loop_header_id, _)+        | checkYield && isJust mb_stk_hwm -> emitLabel loop_header_id+    _otherwise -> return ()++  if (isJust mb_alloc_lit)+    then do+     tickyHeapCheck+     emitAssign hpReg bump_hp+     emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False)+    else do+      when (checkYield && not (gopt Opt_OmitYields dflags)) $ do+         -- Yielding if HpLim == 0+         let yielding = CmmMachOp (mo_wordEq dflags)+                                  [CmmReg hpLimReg,+                                   CmmLit (zeroCLit dflags)]+         emit =<< mkCmmIfGoto' yielding gc_id (Just False)++  tscope <- getTickScope+  emitOutOfLine gc_id+   (do_gc, tscope) -- this is expected to jump back somewhere++                -- Test for stack pointer exhaustion, then+                -- bump heap pointer, and test for heap exhaustion+                -- Note that we don't move the heap pointer unless the+                -- stack check succeeds.  Otherwise we might end up+                -- with slop at the end of the current block, which can+                -- confuse the LDV profiler.++-- Note [Self-recursive loop header]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Self-recursive loop header is required by loopification optimization (See+-- Note [Self-recursive tail calls] in GHC.StgToCmm.Expr). We emit it if:+--+--  1. There is information about self-loop in the FCode environment. We don't+--     check the binder (first component of the self_loop_info) because we are+--     certain that if the self-loop info is present then we are compiling the+--     binder body. Reason: the only possible way to get here with the+--     self_loop_info present is from closureCodeBody.+--+--  2. checkYield && isJust mb_stk_hwm. checkYield tells us that it is possible+--     to preempt the heap check (see #367 for motivation behind this check). It+--     is True for heap checks placed at the entry to a function and+--     let-no-escape heap checks but false for other heap checks (eg. in case+--     alternatives or created from hand-written high-level Cmm). The second+--     check (isJust mb_stk_hwm) is true for heap checks at the entry to a+--     function and some heap checks created in hand-written Cmm. Otherwise it+--     is Nothing. In other words the only situation when both conditions are+--     true is when compiling stack and heap checks at the entry to a+--     function. This is the only situation when we want to emit a self-loop+--     label.
+ compiler/GHC/StgToCmm/Hpc.hs view
@@ -0,0 +1,48 @@+-----------------------------------------------------------------------------+--+-- Code generation for coverage+--+-- (c) Galois Connections, Inc. 2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Hpc ( initHpc, mkTickBox ) where++import GhcPrelude++import GHC.StgToCmm.Monad++import MkGraph+import CmmExpr+import CLabel+import Module+import CmmUtils+import GHC.StgToCmm.Utils+import HscTypes+import DynFlags++import Control.Monad++mkTickBox :: DynFlags -> Module -> Int -> CmmAGraph+mkTickBox dflags mod n+  = mkStore tick_box (CmmMachOp (MO_Add W64)+                                [ CmmLoad tick_box b64+                                , CmmLit (CmmInt 1 W64)+                                ])+  where+    tick_box = cmmIndex dflags W64+                        (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)+                        n++initHpc :: Module -> HpcInfo -> FCode ()+-- Emit top-level tables for HPC and return code to initialise+initHpc _ (NoHpcInfo {})+  = return ()+initHpc this_mod (HpcInfo tickCount _hashNo)+  = do dflags <- getDynFlags+       when (gopt Opt_Hpc dflags) $+           do emitDataLits (mkHpcTicksLabel this_mod)+                           [ (CmmInt 0 W64)+                           | _ <- take tickCount [0 :: Int ..]+                           ]+
+ compiler/GHC/StgToCmm/Layout.hs view
@@ -0,0 +1,623 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Building info tables.+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Layout (+        mkArgDescr,+        emitCall, emitReturn, adjustHpBackwards,++        emitClosureProcAndInfoTable,+        emitClosureAndInfoTable,++        slowCall, directCall,++        FieldOffOrPadding(..),+        ClosureHeader(..),+        mkVirtHeapOffsets,+        mkVirtHeapOffsetsWithPadding,+        mkVirtConstrOffsets,+        mkVirtConstrSizes,+        getHpRelOffset,++        ArgRep(..), toArgRep, argRepSizeW -- re-exported from GHC.StgToCmm.ArgRep+  ) where+++#include "HsVersions.h"++import GhcPrelude hiding ((<*>))++import GHC.StgToCmm.Closure+import GHC.StgToCmm.Env+import GHC.StgToCmm.ArgRep -- notably: ( slowCallPattern )+import GHC.StgToCmm.Ticky+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Utils++import MkGraph+import SMRep+import BlockId+import Cmm+import CmmUtils+import CmmInfo+import CLabel+import StgSyn+import Id+import TyCon             ( PrimRep(..), primRepSizeB )+import BasicTypes        ( RepArity )+import DynFlags+import Module++import Util+import Data.List+import Outputable+import FastString+import Control.Monad++------------------------------------------------------------------------+--                Call and return sequences+------------------------------------------------------------------------++-- | Return multiple values to the sequel+--+-- If the sequel is @Return@+--+-- >     return (x,y)+--+-- If the sequel is @AssignTo [p,q]@+--+-- >    p=x; q=y;+--+emitReturn :: [CmmExpr] -> FCode ReturnKind+emitReturn results+  = do { dflags    <- getDynFlags+       ; sequel    <- getSequel+       ; updfr_off <- getUpdFrameOff+       ; case sequel of+           Return ->+             do { adjustHpBackwards+                ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags)+                ; emit (mkReturn dflags (entryCode dflags e) results updfr_off)+                }+           AssignTo regs adjust ->+             do { when adjust adjustHpBackwards+                ; emitMultiAssign  regs results }+       ; return AssignedDirectly+       }+++-- | @emitCall conv fun args@ makes a call to the entry-code of @fun@,+-- using the call/return convention @conv@, passing @args@, and+-- returning the results to the current sequel.+--+emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ReturnKind+emitCall convs fun args+  = emitCallWithExtraStack convs fun args noExtraStack+++-- | @emitCallWithExtraStack conv fun args stack@ makes a call to the+-- entry-code of @fun@, using the call/return convention @conv@,+-- passing @args@, pushing some extra stack frames described by+-- @stack@, and returning the results to the current sequel.+--+emitCallWithExtraStack+   :: (Convention, Convention) -> CmmExpr -> [CmmExpr]+   -> [CmmExpr] -> FCode ReturnKind+emitCallWithExtraStack (callConv, retConv) fun args extra_stack+  = do  { dflags <- getDynFlags+        ; adjustHpBackwards+        ; sequel <- getSequel+        ; updfr_off <- getUpdFrameOff+        ; case sequel of+            Return -> do+              emit $ mkJumpExtra dflags callConv fun args updfr_off extra_stack+              return AssignedDirectly+            AssignTo res_regs _ -> do+              k <- newBlockId+              let area = Young k+                  (off, _, copyin) = copyInOflow dflags retConv area res_regs []+                  copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off+                                   extra_stack+              tscope <- getTickScope+              emit (copyout <*> mkLabel k tscope <*> copyin)+              return (ReturnedTo k off)+      }+++adjustHpBackwards :: FCode ()+-- This function adjusts the heap pointer just before a tail call or+-- return.  At a call or return, the virtual heap pointer may be less+-- than the real Hp, because the latter was advanced to deal with+-- the worst-case branch of the code, and we may be in a better-case+-- branch.  In that case, move the real Hp *back* and retract some+-- ticky allocation count.+--+-- It *does not* deal with high-water-mark adjustment.  That's done by+-- functions which allocate heap.+adjustHpBackwards+  = do  { hp_usg <- getHpUsage+        ; let rHp = realHp hp_usg+              vHp = virtHp hp_usg+              adjust_words = vHp -rHp+        ; new_hp <- getHpRelOffset vHp++        ; emit (if adjust_words == 0+                then mkNop+                else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp++        ; tickyAllocHeap False adjust_words -- ...ditto++        ; setRealHp vHp+        }+++-------------------------------------------------------------------------+--        Making calls: directCall and slowCall+-------------------------------------------------------------------------++-- General plan is:+--   - we'll make *one* fast call, either to the function itself+--     (directCall) or to stg_ap_<pat>_fast (slowCall)+--     Any left-over arguments will be pushed on the stack,+--+--     e.g. Sp[old+8]  = arg1+--          Sp[old+16] = arg2+--          Sp[old+32] = stg_ap_pp_info+--          R2 = arg3+--          R3 = arg4+--          call f() return to Nothing updfr_off: 32+++directCall :: Convention -> CLabel -> RepArity -> [StgArg] -> FCode ReturnKind+-- (directCall f n args)+-- calls f(arg1, ..., argn), and applies the result to the remaining args+-- The function f has arity n, and there are guaranteed at least n args+-- Both arity and args include void args+directCall conv lbl arity stg_args+  = do  { argreps <- getArgRepsAmodes stg_args+        ; direct_call "directCall" conv lbl arity argreps }+++slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind+-- (slowCall fun args) applies fun to args, returning the results to Sequel+slowCall fun stg_args+  = do  dflags <- getDynFlags+        argsreps <- getArgRepsAmodes stg_args+        let (rts_fun, arity) = slowCallPattern (map fst argsreps)++        (r, slow_code) <- getCodeR $ do+           r <- direct_call "slow_call" NativeNodeCall+                 (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps)+           emitComment $ mkFastString ("slow_call for " +++                                      showSDoc dflags (ppr fun) +++                                      " with pat " ++ unpackFS rts_fun)+           return r++        -- Note [avoid intermediate PAPs]+        let n_args = length stg_args+        if n_args > arity && optLevel dflags >= 2+           then do+             funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun+             fun_iptr <- (CmmReg . CmmLocal) `fmap`+                    assignTemp (closureInfoPtr dflags (cmmUntag dflags funv))++             -- ToDo: we could do slightly better here by reusing the+             -- continuation from the slow call, which we have in r.+             -- Also we'd like to push the continuation on the stack+             -- before the branch, so that we only get one copy of the+             -- code that saves all the live variables across the+             -- call, but that might need some improvements to the+             -- special case in the stack layout code to handle this+             -- (see Note [diamond proc point]).++             fast_code <- getCode $+                emitCall (NativeNodeCall, NativeReturn)+                  (entryCode dflags fun_iptr)+                  (nonVArgs ((P,Just funv):argsreps))++             slow_lbl <- newBlockId+             fast_lbl <- newBlockId+             is_tagged_lbl <- newBlockId+             end_lbl <- newBlockId++             let correct_arity = cmmEqWord dflags (funInfoArity dflags fun_iptr)+                                                  (mkIntExpr dflags n_args)++             tscope <- getTickScope+             emit (mkCbranch (cmmIsTagged dflags funv)+                             is_tagged_lbl slow_lbl (Just True)+                   <*> mkLabel is_tagged_lbl tscope+                   <*> mkCbranch correct_arity fast_lbl slow_lbl (Just True)+                   <*> mkLabel fast_lbl tscope+                   <*> fast_code+                   <*> mkBranch end_lbl+                   <*> mkLabel slow_lbl tscope+                   <*> slow_code+                   <*> mkLabel end_lbl tscope)+             return r++           else do+             emit slow_code+             return r+++-- Note [avoid intermediate PAPs]+--+-- A slow call which needs multiple generic apply patterns will be+-- almost guaranteed to create one or more intermediate PAPs when+-- applied to a function that takes the correct number of arguments.+-- We try to avoid this situation by generating code to test whether+-- we are calling a function with the correct number of arguments+-- first, i.e.:+--+--   if (TAG(f) != 0} {  // f is not a thunk+--      if (f->info.arity == n) {+--         ... make a fast call to f ...+--      }+--   }+--   ... otherwise make the slow call ...+--+-- We *only* do this when the call requires multiple generic apply+-- functions, which requires pushing extra stack frames and probably+-- results in intermediate PAPs.  (I say probably, because it might be+-- that we're over-applying a function, but that seems even less+-- likely).+--+-- This very rarely applies, but if it does happen in an inner loop it+-- can have a severe impact on performance (#6084).+++--------------+direct_call :: String+            -> Convention     -- e.g. NativeNodeCall or NativeDirectCall+            -> CLabel -> RepArity+            -> [(ArgRep,Maybe CmmExpr)] -> FCode ReturnKind+direct_call caller call_conv lbl arity args+  | debugIsOn && args `lengthLessThan` real_arity  -- Too few args+  = do -- Caller should ensure that there enough args!+       pprPanic "direct_call" $+            text caller <+> ppr arity <+>+            ppr lbl <+> ppr (length args) <+>+            ppr (map snd args) <+> ppr (map fst args)++  | null rest_args  -- Precisely the right number of arguments+  = emitCall (call_conv, NativeReturn) target (nonVArgs args)++  | otherwise       -- Note [over-saturated calls]+  = do dflags <- getDynFlags+       emitCallWithExtraStack (call_conv, NativeReturn)+                              target+                              (nonVArgs fast_args)+                              (nonVArgs (stack_args dflags))+  where+    target = CmmLit (CmmLabel lbl)+    (fast_args, rest_args) = splitAt real_arity args+    stack_args dflags = slowArgs dflags rest_args+    real_arity = case call_conv of+                   NativeNodeCall -> arity+1+                   _              -> arity+++-- When constructing calls, it is easier to keep the ArgReps and the+-- CmmExprs zipped together.  However, a void argument has no+-- representation, so we need to use Maybe CmmExpr (the alternative of+-- using zeroCLit or even undefined would work, but would be ugly).+--+getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]+getArgRepsAmodes = mapM getArgRepAmode+  where getArgRepAmode arg+           | V <- rep  = return (V, Nothing)+           | otherwise = do expr <- getArgAmode (NonVoid arg)+                            return (rep, Just expr)+           where rep = toArgRep (argPrimRep arg)++nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]+nonVArgs [] = []+nonVArgs ((_,Nothing)  : args) = nonVArgs args+nonVArgs ((_,Just arg) : args) = arg : nonVArgs args++{-+Note [over-saturated calls]++The natural thing to do for an over-saturated call would be to call+the function with the correct number of arguments, and then apply the+remaining arguments to the value returned, e.g.++  f a b c d   (where f has arity 2)+  -->+  r = call f(a,b)+  call r(c,d)++but this entails+  - saving c and d on the stack+  - making a continuation info table+  - at the continuation, loading c and d off the stack into regs+  - finally, call r++Note that since there are a fixed number of different r's+(e.g.  stg_ap_pp_fast), we can also pre-compile continuations+that correspond to each of them, rather than generating a fresh+one for each over-saturated call.++Not only does this generate much less code, it is faster too.  We will+generate something like:++Sp[old+16] = c+Sp[old+24] = d+Sp[old+32] = stg_ap_pp_info+call f(a,b) -- usual calling convention++For the purposes of the CmmCall node, we count this extra stack as+just more arguments that we are passing on the stack (cml_args).+-}++-- | 'slowArgs' takes a list of function arguments and prepares them for+-- pushing on the stack for "extra" arguments to a function which requires+-- fewer arguments than we currently have.+slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]+slowArgs _ [] = []+slowArgs dflags args -- careful: reps contains voids (V), but args does not+  | gopt Opt_SccProfilingOn dflags+              = save_cccs ++ this_pat ++ slowArgs dflags rest_args+  | otherwise =              this_pat ++ slowArgs dflags rest_args+  where+    (arg_pat, n)            = slowCallPattern (map fst args)+    (call_args, rest_args)  = splitAt n args++    stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat+    this_pat   = (N, Just (mkLblExpr stg_ap_pat)) : call_args+    save_cccs  = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just cccsExpr)]+    save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit "stg_restore_cccs")++-------------------------------------------------------------------------+----        Laying out objects on the heap and stack+-------------------------------------------------------------------------++-- The heap always grows upwards, so hpRel is easy to compute+hpRel :: VirtualHpOffset         -- virtual offset of Hp+      -> VirtualHpOffset         -- virtual offset of The Thing+      -> WordOff                -- integer word offset+hpRel hp off = off - hp++getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr+-- See Note [Virtual and real heap pointers] in GHC.StgToCmm.Monad+getHpRelOffset virtual_offset+  = do dflags <- getDynFlags+       hp_usg <- getHpUsage+       return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset))++data FieldOffOrPadding a+    = FieldOff (NonVoid a) -- Something that needs an offset.+               ByteOff     -- Offset in bytes.+    | Padding ByteOff  -- Length of padding in bytes.+              ByteOff  -- Offset in bytes.++-- | Used to tell the various @mkVirtHeapOffsets@ functions what kind+-- of header the object has.  This will be accounted for in the+-- offsets of the fields returned.+data ClosureHeader+  = NoHeader+  | StdHeader+  | ThunkHeader++mkVirtHeapOffsetsWithPadding+  :: DynFlags+  -> ClosureHeader            -- What kind of header to account for+  -> [NonVoid (PrimRep, a)]   -- Things to make offsets for+  -> ( WordOff                -- Total number of words allocated+     , WordOff                -- Number of words allocated for *pointers*+     , [FieldOffOrPadding a]  -- Either an offset or padding.+     )++-- Things with their offsets from start of object in order of+-- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER+-- First in list gets lowest offset, which is initial offset + 1.+--+-- mkVirtHeapOffsetsWithPadding always returns boxed things with smaller offsets+-- than the unboxed things++mkVirtHeapOffsetsWithPadding dflags header things =+    ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))+    ( tot_wds+    , bytesToWordsRoundUp dflags bytes_of_ptrs+    , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad+    )+  where+    hdr_words = case header of+      NoHeader -> 0+      StdHeader -> fixedHdrSizeW dflags+      ThunkHeader -> thunkHdrSize dflags+    hdr_bytes = wordsToBytes dflags hdr_words++    (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things++    (bytes_of_ptrs, ptrs_w_offsets) =+       mapAccumL computeOffset 0 ptrs+    (tot_bytes, non_ptrs_w_offsets) =+       mapAccumL computeOffset bytes_of_ptrs non_ptrs++    tot_wds = bytesToWordsRoundUp dflags tot_bytes++    final_pad_size = tot_wds * word_size - tot_bytes+    final_pad+        | final_pad_size > 0 = [(Padding final_pad_size+                                         (hdr_bytes + tot_bytes))]+        | otherwise          = []++    word_size = wORD_SIZE dflags++    computeOffset bytes_so_far nv_thing =+        (new_bytes_so_far, with_padding field_off)+      where+        (rep, thing) = fromNonVoid nv_thing++        -- Size of the field in bytes.+        !sizeB = primRepSizeB dflags rep++        -- Align the start offset (eg, 2-byte value should be 2-byte aligned).+        -- But not more than to a word.+        !align = min word_size sizeB+        !start = roundUpTo bytes_so_far align+        !padding = start - bytes_so_far++        -- Final offset is:+        --   size of header + bytes_so_far + padding+        !final_offset = hdr_bytes + bytes_so_far + padding+        !new_bytes_so_far = start + sizeB+        field_off = FieldOff (NonVoid thing) final_offset++        with_padding field_off+            | padding == 0 = [field_off]+            | otherwise    = [ Padding padding (hdr_bytes + bytes_so_far)+                             , field_off+                             ]+++mkVirtHeapOffsets+  :: DynFlags+  -> ClosureHeader            -- What kind of header to account for+  -> [NonVoid (PrimRep,a)]    -- Things to make offsets for+  -> (WordOff,                -- _Total_ number of words allocated+      WordOff,                -- Number of words allocated for *pointers*+      [(NonVoid a, ByteOff)])+mkVirtHeapOffsets dflags header things =+    ( tot_wds+    , ptr_wds+    , [ (field, offset) | (FieldOff field offset) <- things_offsets ]+    )+  where+   (tot_wds, ptr_wds, things_offsets) =+       mkVirtHeapOffsetsWithPadding dflags header things++-- | Just like mkVirtHeapOffsets, but for constructors+mkVirtConstrOffsets+  :: DynFlags -> [NonVoid (PrimRep, a)]+  -> (WordOff, WordOff, [(NonVoid a, ByteOff)])+mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags StdHeader++-- | Just like mkVirtConstrOffsets, but used when we don't have the actual+-- arguments. Useful when e.g. generating info tables; we just need to know+-- sizes of pointer and non-pointer fields.+mkVirtConstrSizes :: DynFlags -> [NonVoid PrimRep] -> (WordOff, WordOff)+mkVirtConstrSizes dflags field_reps+  = (tot_wds, ptr_wds)+  where+    (tot_wds, ptr_wds, _) =+       mkVirtConstrOffsets dflags+         (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps)++-------------------------------------------------------------------------+--+--        Making argument descriptors+--+--  An argument descriptor describes the layout of args on the stack,+--  both for         * GC (stack-layout) purposes, and+--                * saving/restoring registers when a heap-check fails+--+-- Void arguments aren't important, therefore (contrast constructSlowCall)+--+-------------------------------------------------------------------------++-- bring in ARG_P, ARG_N, etc.+#include "rts/storage/FunTypes.h"++mkArgDescr :: DynFlags -> [Id] -> ArgDescr+mkArgDescr dflags args+  = let arg_bits = argBits dflags arg_reps+        arg_reps = filter isNonV (map idArgRep args)+           -- Getting rid of voids eases matching of standard patterns+    in case stdPattern arg_reps of+         Just spec_id -> ArgSpec spec_id+         Nothing      -> ArgGen  arg_bits++argBits :: DynFlags -> [ArgRep] -> [Bool]        -- True for non-ptr, False for ptr+argBits _      []           = []+argBits dflags (P   : args) = False : argBits dflags args+argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True)+                    ++ argBits dflags args++----------------------+stdPattern :: [ArgRep] -> Maybe Int+stdPattern reps+  = case reps of+        []    -> Just ARG_NONE        -- just void args, probably+        [N]   -> Just ARG_N+        [P]   -> Just ARG_P+        [F]   -> Just ARG_F+        [D]   -> Just ARG_D+        [L]   -> Just ARG_L+        [V16] -> Just ARG_V16+        [V32] -> Just ARG_V32+        [V64] -> Just ARG_V64++        [N,N] -> Just ARG_NN+        [N,P] -> Just ARG_NP+        [P,N] -> Just ARG_PN+        [P,P] -> Just ARG_PP++        [N,N,N] -> Just ARG_NNN+        [N,N,P] -> Just ARG_NNP+        [N,P,N] -> Just ARG_NPN+        [N,P,P] -> Just ARG_NPP+        [P,N,N] -> Just ARG_PNN+        [P,N,P] -> Just ARG_PNP+        [P,P,N] -> Just ARG_PPN+        [P,P,P] -> Just ARG_PPP++        [P,P,P,P]     -> Just ARG_PPPP+        [P,P,P,P,P]   -> Just ARG_PPPPP+        [P,P,P,P,P,P] -> Just ARG_PPPPPP++        _ -> Nothing++-------------------------------------------------------------------------+--+--        Generating the info table and code for a closure+--+-------------------------------------------------------------------------++-- Here we make an info table of type 'CmmInfo'.  The concrete+-- representation as a list of 'CmmAddr' is handled later+-- in the pipeline by 'cmmToRawCmm'.+-- When loading the free variables, a function closure pointer may be tagged,+-- so we must take it into account.++emitClosureProcAndInfoTable :: Bool                    -- top-level?+                            -> Id                      -- name of the closure+                            -> LambdaFormInfo+                            -> CmmInfoTable+                            -> [NonVoid Id]            -- incoming arguments+                            -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body+                            -> FCode ()+emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body+ = do   { dflags <- getDynFlags+        -- Bind the binder itself, but only if it's not a top-level+        -- binding. We need non-top let-bindings to refer to the+        -- top-level binding, which this binding would incorrectly shadow.+        ; node <- if top_lvl then return $ idToReg dflags (NonVoid bndr)+                  else bindToReg (NonVoid bndr) lf_info+        ; let node_points = nodeMustPointToIt dflags lf_info+        ; arg_regs <- bindArgsToRegs args+        ; let args' = if node_points then (node : arg_regs) else arg_regs+              conv  = if nodeMustPointToIt dflags lf_info then NativeNodeCall+                                                          else NativeDirectCall+              (offset, _, _) = mkCallEntry dflags conv args' []+        ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs)+        }++-- Data constructors need closures, but not with all the argument handling+-- needed for functions. The shared part goes here.+emitClosureAndInfoTable ::+  CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()+emitClosureAndInfoTable info_tbl conv args body+  = do { (_, blks) <- getCodeScoped body+       ; let entry_lbl = toEntryLbl (cit_lbl info_tbl)+       ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks+       }
+ compiler/GHC/StgToCmm/Monad.hs view
@@ -0,0 +1,861 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs #-}++-----------------------------------------------------------------------------+--+-- Monad for Stg to C-- code generation+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Monad (+        FCode,        -- type++        initC, runC, fixC,+        newUnique,++        emitLabel,++        emit, emitDecl,+        emitProcWithConvention, emitProcWithStackFrame,+        emitOutOfLine, emitAssign, emitStore,+        emitComment, emitTick, emitUnwind,++        getCmm, aGraphToGraph,+        getCodeR, getCode, getCodeScoped, getHeapUsage,++        mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,+        mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto',++        mkCall, mkCmmCall,++        forkClosureBody, forkLneBody, forkAlts, forkAltPair, codeOnly,++        ConTagZ,++        Sequel(..), ReturnKind(..),+        withSequel, getSequel,++        setTickyCtrLabel, getTickyCtrLabel,+        tickScope, getTickScope,++        withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,++        HeapUsage(..), VirtualHpOffset,        initHpUsage,+        getHpUsage,  setHpUsage, heapHWM,+        setVirtHp, getVirtHp, setRealHp,++        getModuleName,++        -- ideally we wouldn't export these, but some other modules access internal state+        getState, setState, getSelfLoop, withSelfLoop, getInfoDown, getDynFlags, getThisPackage,++        -- more localised access to monad state+        CgIdInfo(..),+        getBinds, setBinds,++        -- out of general friendliness, we also export ...+        CgInfoDownwards(..), CgState(..)        -- non-abstract+    ) where++import GhcPrelude hiding( sequence, succ )++import Cmm+import GHC.StgToCmm.Closure+import DynFlags+import Hoopl.Collections+import MkGraph+import BlockId+import CLabel+import SMRep+import Module+import Id+import VarEnv+import OrdList+import BasicTypes( ConTagZ )+import Unique+import UniqSupply+import FastString+import Outputable+import Util++import Control.Monad+import Data.List++++--------------------------------------------------------+-- The FCode monad and its types+--+-- FCode is the monad plumbed through the Stg->Cmm code generator, and+-- the Cmm parser.  It contains the following things:+--+--  - A writer monad, collecting:+--    - code for the current function, in the form of a CmmAGraph.+--      The function "emit" appends more code to this.+--    - the top-level CmmDecls accumulated so far+--+--  - A state monad with:+--    - the local bindings in scope+--    - the current heap usage+--    - a UniqSupply+--+--  - A reader monad, for CgInfoDownwards, containing+--    - DynFlags,+--    - the current Module+--    - the update-frame offset+--    - the ticky counter label+--    - the Sequel (the continuation to return to)+--    - the self-recursive tail call information++--------------------------------------------------------++newtype FCode a = FCode { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) }+    deriving (Functor)++instance Applicative FCode where+    pure val = FCode (\_info_down state -> (val, state))+    {-# INLINE pure #-}+    (<*>) = ap++instance Monad FCode where+    FCode m >>= k = FCode $+        \info_down state ->+            case m info_down state of+              (m_result, new_state) ->+                 case k m_result of+                   FCode kcode -> kcode info_down new_state+    {-# INLINE (>>=) #-}++instance MonadUnique FCode where+  getUniqueSupplyM = cgs_uniqs <$> getState+  getUniqueM = FCode $ \_ st ->+    let (u, us') = takeUniqFromSupply (cgs_uniqs st)+    in (u, st { cgs_uniqs = us' })++initC :: IO CgState+initC  = do { uniqs <- mkSplitUniqSupply 'c'+            ; return (initCgState uniqs) }++runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)+runC dflags mod st fcode = doFCode fcode (initCgInfoDown dflags mod) st++fixC :: (a -> FCode a) -> FCode a+fixC fcode = FCode $+    \info_down state -> let (v, s) = doFCode (fcode v) info_down state+                        in (v, s)++--------------------------------------------------------+--        The code generator environment+--------------------------------------------------------++-- This monadery has some information that it only passes+-- *downwards*, as well as some ``state'' which is modified+-- as we go along.++data CgInfoDownwards        -- information only passed *downwards* by the monad+  = MkCgInfoDown {+        cgd_dflags    :: DynFlags,+        cgd_mod       :: Module,            -- Module being compiled+        cgd_updfr_off :: UpdFrameOffset,    -- Size of current update frame+        cgd_ticky     :: CLabel,            -- Current destination for ticky counts+        cgd_sequel    :: Sequel,            -- What to do at end of basic block+        cgd_self_loop :: Maybe SelfLoopInfo,-- Which tail calls can be compiled+                                            -- as local jumps? See Note+                                            -- [Self-recursive tail calls] in+                                            -- GHC.StgToCmm.Expr+        cgd_tick_scope:: CmmTickScope       -- Tick scope for new blocks & ticks+  }++type CgBindings = IdEnv CgIdInfo++data CgIdInfo+  = CgIdInfo+        { cg_id :: Id   -- Id that this is the info for+        , cg_lf  :: LambdaFormInfo+        , cg_loc :: CgLoc                     -- CmmExpr for the *tagged* value+        }++instance Outputable CgIdInfo where+  ppr (CgIdInfo { cg_id = id, cg_loc = loc })+    = ppr id <+> text "-->" <+> ppr loc++-- Sequel tells what to do with the result of this expression+data Sequel+  = Return              -- Return result(s) to continuation found on the stack.++  | AssignTo+        [LocalReg]      -- Put result(s) in these regs and fall through+                        -- NB: no void arguments here+                        --+        Bool            -- Should we adjust the heap pointer back to+                        -- recover space that's unused on this path?+                        -- We need to do this only if the expression+                        -- may allocate (e.g. it's a foreign call or+                        -- allocating primOp)++instance Outputable Sequel where+    ppr Return = text "Return"+    ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b++-- See Note [sharing continuations] below+data ReturnKind+  = AssignedDirectly+  | ReturnedTo BlockId ByteOff++-- Note [sharing continuations]+--+-- ReturnKind says how the expression being compiled returned its+-- results: either by assigning directly to the registers specified+-- by the Sequel, or by returning to a continuation that does the+-- assignments.  The point of this is we might be able to re-use the+-- continuation in a subsequent heap-check.  Consider:+--+--    case f x of z+--      True  -> <True code>+--      False -> <False code>+--+-- Naively we would generate+--+--    R2 = x   -- argument to f+--    Sp[young(L1)] = L1+--    call f returns to L1+--  L1:+--    z = R1+--    if (z & 1) then Ltrue else Lfalse+--  Ltrue:+--    Hp = Hp + 24+--    if (Hp > HpLim) then L4 else L7+--  L4:+--    HpAlloc = 24+--    goto L5+--  L5:+--    R1 = z+--    Sp[young(L6)] = L6+--    call stg_gc_unpt_r1 returns to L6+--  L6:+--    z = R1+--    goto L1+--  L7:+--    <True code>+--  Lfalse:+--    <False code>+--+-- We want the gc call in L4 to return to L1, and discard L6.  Note+-- that not only can we share L1 and L6, but the assignment of the+-- return address in L4 is unnecessary because the return address for+-- L1 is already on the stack.  We used to catch the sharing of L1 and+-- L6 in the common-block-eliminator, but not the unnecessary return+-- address assignment.+--+-- Since this case is so common I decided to make it more explicit and+-- robust by programming the sharing directly, rather than relying on+-- the common-block eliminator to catch it.  This makes+-- common-block-elimination an optional optimisation, and furthermore+-- generates less code in the first place that we have to subsequently+-- clean up.+--+-- There are some rarer cases of common blocks that we don't catch+-- this way, but that's ok.  Common-block-elimination is still available+-- to catch them when optimisation is enabled.  Some examples are:+--+--   - when both the True and False branches do a heap check, we+--     can share the heap-check failure code L4a and maybe L4+--+--   - in a case-of-case, there might be multiple continuations that+--     we can common up.+--+-- It is always safe to use AssignedDirectly.  Expressions that jump+-- to the continuation from multiple places (e.g. case expressions)+-- fall back to AssignedDirectly.+--+++initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards+initCgInfoDown dflags mod+  = MkCgInfoDown { cgd_dflags    = dflags+                 , cgd_mod       = mod+                 , cgd_updfr_off = initUpdFrameOff dflags+                 , cgd_ticky     = mkTopTickyCtrLabel+                 , cgd_sequel    = initSequel+                 , cgd_self_loop = Nothing+                 , cgd_tick_scope= GlobalScope }++initSequel :: Sequel+initSequel = Return++initUpdFrameOff :: DynFlags -> UpdFrameOffset+initUpdFrameOff dflags = widthInBytes (wordWidth dflags) -- space for the RA+++--------------------------------------------------------+--        The code generator state+--------------------------------------------------------++data CgState+  = MkCgState {+     cgs_stmts :: CmmAGraph,          -- Current procedure++     cgs_tops  :: OrdList CmmDecl,+        -- Other procedures and data blocks in this compilation unit+        -- Both are ordered only so that we can+        -- reduce forward references, when it's easy to do so++     cgs_binds :: CgBindings,++     cgs_hp_usg  :: HeapUsage,++     cgs_uniqs :: UniqSupply }++data HeapUsage   -- See Note [Virtual and real heap pointers]+  = HeapUsage {+        virtHp :: VirtualHpOffset,       -- Virtual offset of highest-allocated word+                                         --   Incremented whenever we allocate+        realHp :: VirtualHpOffset        -- realHp: Virtual offset of real heap ptr+                                         --   Used in instruction addressing modes+    }++type VirtualHpOffset = WordOff+++{- Note [Virtual and real heap pointers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The code generator can allocate one or more objects contiguously, performing+one heap check to cover allocation of all the objects at once.  Let's call+this little chunk of heap space an "allocation chunk".  The code generator+will emit code to+  * Perform a heap-exhaustion check+  * Move the heap pointer to the end of the allocation chunk+  * Allocate multiple objects within the chunk++The code generator uses VirtualHpOffsets to address words within a+single allocation chunk; these start at one and increase positively.+The first word of the chunk has VirtualHpOffset=1, the second has+VirtualHpOffset=2, and so on.++ * The field realHp tracks (the VirtualHpOffset) where the real Hp+   register is pointing.  Typically it'll be pointing to the end of the+   allocation chunk.++ * The field virtHp gives the VirtualHpOffset of the highest-allocated+   word so far.  It starts at zero (meaning no word has been allocated),+   and increases whenever an object is allocated.++The difference between realHp and virtHp gives the offset from the+real Hp register of a particular word in the allocation chunk. This+is what getHpRelOffset does.  Since the returned offset is relative+to the real Hp register, it is valid only until you change the real+Hp register.  (Changing virtHp doesn't matter.)+-}+++initCgState :: UniqSupply -> CgState+initCgState uniqs+  = MkCgState { cgs_stmts  = mkNop+              , cgs_tops   = nilOL+              , cgs_binds  = emptyVarEnv+              , cgs_hp_usg = initHpUsage+              , cgs_uniqs  = uniqs }++stateIncUsage :: CgState -> CgState -> CgState+-- stateIncUsage@ e1 e2 incorporates in e1+-- the heap high water mark found in e2.+stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg })+     = s1 { cgs_hp_usg  = cgs_hp_usg  s1 `maxHpHw`  virtHp hp_usg }+       `addCodeBlocksFrom` s2++addCodeBlocksFrom :: CgState -> CgState -> CgState+-- Add code blocks from the latter to the former+-- (The cgs_stmts will often be empty, but not always; see codeOnly)+s1 `addCodeBlocksFrom` s2+  = s1 { cgs_stmts = cgs_stmts s1 MkGraph.<*> cgs_stmts s2,+         cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }+++-- The heap high water mark is the larger of virtHp and hwHp.  The latter is+-- only records the high water marks of forked-off branches, so to find the+-- heap high water mark you have to take the max of virtHp and hwHp.  Remember,+-- virtHp never retreats!+--+-- Note Jan 04: ok, so why do we only look at the virtual Hp??++heapHWM :: HeapUsage -> VirtualHpOffset+heapHWM = virtHp++initHpUsage :: HeapUsage+initHpUsage = HeapUsage { virtHp = 0, realHp = 0 }++maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage+hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }++--------------------------------------------------------+-- Operators for getting and setting the state and "info_down".+--------------------------------------------------------++getState :: FCode CgState+getState = FCode $ \_info_down state -> (state, state)++setState :: CgState -> FCode ()+setState state = FCode $ \_info_down _ -> ((), state)++getHpUsage :: FCode HeapUsage+getHpUsage = do+        state <- getState+        return $ cgs_hp_usg state++setHpUsage :: HeapUsage -> FCode ()+setHpUsage new_hp_usg = do+        state <- getState+        setState $ state {cgs_hp_usg = new_hp_usg}++setVirtHp :: VirtualHpOffset -> FCode ()+setVirtHp new_virtHp+  = do  { hp_usage <- getHpUsage+        ; setHpUsage (hp_usage {virtHp = new_virtHp}) }++getVirtHp :: FCode VirtualHpOffset+getVirtHp+  = do  { hp_usage <- getHpUsage+        ; return (virtHp hp_usage) }++setRealHp ::  VirtualHpOffset -> FCode ()+setRealHp new_realHp+  = do  { hp_usage <- getHpUsage+        ; setHpUsage (hp_usage {realHp = new_realHp}) }++getBinds :: FCode CgBindings+getBinds = do+        state <- getState+        return $ cgs_binds state++setBinds :: CgBindings -> FCode ()+setBinds new_binds = do+        state <- getState+        setState $ state {cgs_binds = new_binds}++withState :: FCode a -> CgState -> FCode (a,CgState)+withState (FCode fcode) newstate = FCode $ \info_down state ->+  case fcode info_down newstate of+    (retval, state2) -> ((retval,state2), state)++newUniqSupply :: FCode UniqSupply+newUniqSupply = do+        state <- getState+        let (us1, us2) = splitUniqSupply (cgs_uniqs state)+        setState $ state { cgs_uniqs = us1 }+        return us2++newUnique :: FCode Unique+newUnique = do+        state <- getState+        let (u,us') = takeUniqFromSupply (cgs_uniqs state)+        setState $ state { cgs_uniqs = us' }+        return u++------------------+getInfoDown :: FCode CgInfoDownwards+getInfoDown = FCode $ \info_down state -> (info_down,state)++getSelfLoop :: FCode (Maybe SelfLoopInfo)+getSelfLoop = do+        info_down <- getInfoDown+        return $ cgd_self_loop info_down++withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a+withSelfLoop self_loop code = do+        info_down <- getInfoDown+        withInfoDown code (info_down {cgd_self_loop = Just self_loop})++instance HasDynFlags FCode where+    getDynFlags = liftM cgd_dflags getInfoDown++getThisPackage :: FCode UnitId+getThisPackage = liftM thisPackage getDynFlags++withInfoDown :: FCode a -> CgInfoDownwards -> FCode a+withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state++-- ----------------------------------------------------------------------------+-- Get the current module name++getModuleName :: FCode Module+getModuleName = do { info <- getInfoDown; return (cgd_mod info) }++-- ----------------------------------------------------------------------------+-- Get/set the end-of-block info++withSequel :: Sequel -> FCode a -> FCode a+withSequel sequel code+  = do  { info  <- getInfoDown+        ; withInfoDown code (info {cgd_sequel = sequel, cgd_self_loop = Nothing }) }++getSequel :: FCode Sequel+getSequel = do  { info <- getInfoDown+                ; return (cgd_sequel info) }++-- ----------------------------------------------------------------------------+-- Get/set the size of the update frame++-- We keep track of the size of the update frame so that we+-- can set the stack pointer to the proper address on return+-- (or tail call) from the closure.+-- There should be at most one update frame for each closure.+-- Note: I'm including the size of the original return address+-- in the size of the update frame -- hence the default case on `get'.++withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a+withUpdFrameOff size code+  = do  { info  <- getInfoDown+        ; withInfoDown code (info {cgd_updfr_off = size }) }++getUpdFrameOff :: FCode UpdFrameOffset+getUpdFrameOff+  = do  { info  <- getInfoDown+        ; return $ cgd_updfr_off info }++-- ----------------------------------------------------------------------------+-- Get/set the current ticky counter label++getTickyCtrLabel :: FCode CLabel+getTickyCtrLabel = do+        info <- getInfoDown+        return (cgd_ticky info)++setTickyCtrLabel :: CLabel -> FCode a -> FCode a+setTickyCtrLabel ticky code = do+        info <- getInfoDown+        withInfoDown code (info {cgd_ticky = ticky})++-- ----------------------------------------------------------------------------+-- Manage tick scopes++-- | The current tick scope. We will assign this to generated blocks.+getTickScope :: FCode CmmTickScope+getTickScope = do+        info <- getInfoDown+        return (cgd_tick_scope info)++-- | Places blocks generated by the given code into a fresh+-- (sub-)scope. This will make sure that Cmm annotations in our scope+-- will apply to the Cmm blocks generated therein - but not the other+-- way around.+tickScope :: FCode a -> FCode a+tickScope code = do+        info <- getInfoDown+        if debugLevel (cgd_dflags info) == 0 then code else do+          u <- newUnique+          let scope' = SubScope u (cgd_tick_scope info)+          withInfoDown code info{ cgd_tick_scope = scope' }+++--------------------------------------------------------+--                 Forking+--------------------------------------------------------++forkClosureBody :: FCode () -> FCode ()+-- forkClosureBody compiles body_code in environment where:+--   - sequel, update stack frame and self loop info are+--     set to fresh values+--   - state is set to a fresh value, except for local bindings+--     that are passed in unchanged. It's up to the enclosed code to+--     re-bind the free variables to a field of the closure.++forkClosureBody body_code+  = do  { dflags <- getDynFlags+        ; info   <- getInfoDown+        ; us     <- newUniqSupply+        ; state  <- getState+        ; let body_info_down = info { cgd_sequel    = initSequel+                                    , cgd_updfr_off = initUpdFrameOff dflags+                                    , cgd_self_loop = Nothing }+              fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }+              ((),fork_state_out) = doFCode body_code body_info_down fork_state_in+        ; setState $ state `addCodeBlocksFrom` fork_state_out }++forkLneBody :: FCode a -> FCode a+-- 'forkLneBody' takes a body of let-no-escape binding and compiles+-- it in the *current* environment, returning the graph thus constructed.+--+-- The current environment is passed on completely unchanged to+-- the successor.  In particular, any heap usage from the enclosed+-- code is discarded; it should deal with its own heap consumption.+forkLneBody body_code+  = do  { info_down <- getInfoDown+        ; us        <- newUniqSupply+        ; state     <- getState+        ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }+              (result, fork_state_out) = doFCode body_code info_down fork_state_in+        ; setState $ state `addCodeBlocksFrom` fork_state_out+        ; return result }++codeOnly :: FCode () -> FCode ()+-- Emit any code from the inner thing into the outer thing+-- Do not affect anything else in the outer state+-- Used in almost-circular code to prevent false loop dependencies+codeOnly body_code+  = do  { info_down <- getInfoDown+        ; us        <- newUniqSupply+        ; state     <- getState+        ; let   fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state+                                                 , cgs_hp_usg  = cgs_hp_usg state }+                ((), fork_state_out) = doFCode body_code info_down fork_state_in+        ; setState $ state `addCodeBlocksFrom` fork_state_out }++forkAlts :: [FCode a] -> FCode [a]+-- (forkAlts' bs d) takes fcodes 'bs' for the branches of a 'case', and+-- an fcode for the default case 'd', and compiles each in the current+-- environment.  The current environment is passed on unmodified, except+-- that the virtual Hp is moved on to the worst virtual Hp for the branches++forkAlts branch_fcodes+  = do  { info_down <- getInfoDown+        ; us <- newUniqSupply+        ; state <- getState+        ; let compile us branch+                = (us2, doFCode branch info_down branch_state)+                where+                  (us1,us2) = splitUniqSupply us+                  branch_state = (initCgState us1) {+                                        cgs_binds  = cgs_binds state+                                      , cgs_hp_usg = cgs_hp_usg state }+              (_us, results) = mapAccumL compile us branch_fcodes+              (branch_results, branch_out_states) = unzip results+        ; setState $ foldl' stateIncUsage state branch_out_states+                -- NB foldl.  state is the *left* argument to stateIncUsage+        ; return branch_results }++forkAltPair :: FCode a -> FCode a -> FCode (a,a)+-- Most common use of 'forkAlts'; having this helper function avoids+-- accidental use of failible pattern-matches in @do@-notation+forkAltPair x y = do+  xy' <- forkAlts [x,y]+  case xy' of+    [x',y'] -> return (x',y')+    _ -> panic "forkAltPair"++-- collect the code emitted by an FCode computation+getCodeR :: FCode a -> FCode (a, CmmAGraph)+getCodeR fcode+  = do  { state1 <- getState+        ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop })+        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }+        ; return (a, cgs_stmts state2) }++getCode :: FCode a -> FCode CmmAGraph+getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts }++-- | Generate code into a fresh tick (sub-)scope and gather generated code+getCodeScoped :: FCode a -> FCode (a, CmmAGraphScoped)+getCodeScoped fcode+  = do  { state1 <- getState+        ; ((a, tscope), state2) <-+            tickScope $+            flip withState state1 { cgs_stmts = mkNop } $+            do { a   <- fcode+               ; scp <- getTickScope+               ; return (a, scp) }+        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }+        ; return (a, (cgs_stmts state2, tscope)) }+++-- 'getHeapUsage' applies a function to the amount of heap that it uses.+-- It initialises the heap usage to zeros, and passes on an unchanged+-- heap usage.+--+-- It is usually a prelude to performing a GC check, so everything must+-- be in a tidy and consistent state.+--+-- Note the slightly subtle fixed point behaviour needed here++getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a+getHeapUsage fcode+  = do  { info_down <- getInfoDown+        ; state <- getState+        ; let   fstate_in = state { cgs_hp_usg  = initHpUsage }+                (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in+                hp_hw = heapHWM (cgs_hp_usg fstate_out)        -- Loop here!++        ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }+        ; return r }++-- ----------------------------------------------------------------------------+-- Combinators for emitting code++emitCgStmt :: CgStmt -> FCode ()+emitCgStmt stmt+  = do  { state <- getState+        ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }+        }++emitLabel :: BlockId -> FCode ()+emitLabel id = do tscope <- getTickScope+                  emitCgStmt (CgLabel id tscope)++emitComment :: FastString -> FCode ()+emitComment s+  | debugIsOn = emitCgStmt (CgStmt (CmmComment s))+  | otherwise = return ()++emitTick :: CmmTickish -> FCode ()+emitTick = emitCgStmt . CgStmt . CmmTick++emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode ()+emitUnwind regs = do+  dflags <- getDynFlags+  when (debugLevel dflags > 0) $ do+     emitCgStmt $ CgStmt $ CmmUnwind regs++emitAssign :: CmmReg  -> CmmExpr -> FCode ()+emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))++emitStore :: CmmExpr  -> CmmExpr -> FCode ()+emitStore l r = emitCgStmt (CgStmt (CmmStore l r))++emit :: CmmAGraph -> FCode ()+emit ag+  = do  { state <- getState+        ; setState $ state { cgs_stmts = cgs_stmts state MkGraph.<*> ag } }++emitDecl :: CmmDecl -> FCode ()+emitDecl decl+  = do  { state <- getState+        ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }++emitOutOfLine :: BlockId -> CmmAGraphScoped -> FCode ()+emitOutOfLine l (stmts, tscope) = emitCgStmt (CgFork l stmts tscope)++emitProcWithStackFrame+   :: Convention                        -- entry convention+   -> Maybe CmmInfoTable                -- info table?+   -> CLabel                            -- label for the proc+   -> [CmmFormal]                       -- stack frame+   -> [CmmFormal]                       -- arguments+   -> CmmAGraphScoped                   -- code+   -> Bool                              -- do stack layout?+   -> FCode ()++emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False+  = do  { dflags <- getDynFlags+        ; emitProc mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False+        }+emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True+        -- do layout+  = do  { dflags <- getDynFlags+        ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args+              graph' = entry MkGraph.<*> graph+        ; emitProc mb_info lbl live (graph', tscope) offset True+        }+emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame"++emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel+                       -> [CmmFormal]+                       -> CmmAGraphScoped+                       -> FCode ()+emitProcWithConvention conv mb_info lbl args blocks+  = emitProcWithStackFrame conv mb_info lbl [] args blocks True++emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped+         -> Int -> Bool -> FCode ()+emitProc mb_info lbl live blocks offset do_layout+  = do  { dflags <- getDynFlags+        ; l <- newBlockId+        ; let+              blks :: CmmGraph+              blks = labelAGraph l blocks++              infos | Just info <- mb_info = mapSingleton (g_entry blks) info+                    | otherwise            = mapEmpty++              sinfo = StackInfo { arg_space = offset+                                , updfr_space = Just (initUpdFrameOff dflags)+                                , do_layout = do_layout }++              tinfo = TopInfo { info_tbls = infos+                              , stack_info=sinfo}++              proc_block = CmmProc tinfo lbl live blks++        ; state <- getState+        ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }++getCmm :: FCode () -> FCode CmmGroup+-- Get all the CmmTops (there should be no stmts)+-- Return a single Cmm which may be split from other Cmms by+-- object splitting (at a later stage)+getCmm code+  = do  { state1 <- getState+        ; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })+        ; setState $ state2 { cgs_tops = cgs_tops state1 }+        ; return (fromOL (cgs_tops state2)) }+++mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph+mkCmmIfThenElse e tbranch fbranch = mkCmmIfThenElse' e tbranch fbranch Nothing++mkCmmIfThenElse' :: CmmExpr -> CmmAGraph -> CmmAGraph+                 -> Maybe Bool -> FCode CmmAGraph+mkCmmIfThenElse' e tbranch fbranch likely = do+  tscp  <- getTickScope+  endif <- newBlockId+  tid   <- newBlockId+  fid   <- newBlockId++  let+    (test, then_, else_, likely') = case likely of+      Just False | Just e' <- maybeInvertCmmExpr e+        -- currently NCG doesn't know about likely+        -- annotations. We manually switch then and+        -- else branch so the likely false branch+        -- becomes a fallthrough.+        -> (e', fbranch, tbranch, Just True)+      _ -> (e, tbranch, fbranch, likely)++  return $ catAGraphs [ mkCbranch test tid fid likely'+                      , mkLabel tid tscp, then_, mkBranch endif+                      , mkLabel fid tscp, else_, mkLabel endif tscp ]++mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph+mkCmmIfGoto e tid = mkCmmIfGoto' e tid Nothing++mkCmmIfGoto' :: CmmExpr -> BlockId -> Maybe Bool -> FCode CmmAGraph+mkCmmIfGoto' e tid l = do+  endif <- newBlockId+  tscp  <- getTickScope+  return $ catAGraphs [ mkCbranch e tid endif l, mkLabel endif tscp ]++mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph+mkCmmIfThen e tbranch = mkCmmIfThen' e tbranch Nothing++mkCmmIfThen' :: CmmExpr -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph+mkCmmIfThen' e tbranch l = do+  endif <- newBlockId+  tid   <- newBlockId+  tscp  <- getTickScope+  return $ catAGraphs [ mkCbranch e tid endif l+                      , mkLabel tid tscp, tbranch, mkLabel endif tscp ]++mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmExpr]+       -> UpdFrameOffset -> [CmmExpr] -> FCode CmmAGraph+mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do+  dflags <- getDynFlags+  k      <- newBlockId+  tscp   <- getTickScope+  let area = Young k+      (off, _, copyin) = copyInOflow dflags retConv area results []+      copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack+  return $ catAGraphs [copyout, mkLabel k tscp, copyin]++mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset+          -> FCode CmmAGraph+mkCmmCall f results actuals updfr_off+   = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off []+++-- ----------------------------------------------------------------------------+-- turn CmmAGraph into CmmGraph, for making a new proc.++aGraphToGraph :: CmmAGraphScoped -> FCode CmmGraph+aGraphToGraph stmts+  = do  { l <- newBlockId+        ; return (labelAGraph l stmts) }
+ compiler/GHC/StgToCmm/Prim.hs view
@@ -0,0 +1,3008 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}++#if __GLASGOW_HASKELL__ <= 808+-- GHC 8.10 deprecates this flag, but GHC 8.8 needs it+-- emitPrimOp is quite large+{-# OPTIONS_GHC -fmax-pmcheck-iterations=4000000 #-}+#endif++----------------------------------------------------------------------------+--+-- Stg to C--: primitive operations+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Prim (+   cgOpApp,+   cgPrimOp, -- internal(ish), used by cgCase to get code for a+             -- comparison without also turning it into a Bool.+   shouldInlinePrimOp+ ) where++#include "HsVersions.h"++import GhcPrelude hiding ((<*>))++import GHC.StgToCmm.Layout+import GHC.StgToCmm.Foreign+import GHC.StgToCmm.Env+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Ticky+import GHC.StgToCmm.Heap+import GHC.StgToCmm.Prof ( costCentreFrom )++import DynFlags+import GHC.Platform+import BasicTypes+import BlockId+import MkGraph+import StgSyn+import Cmm+import Module   ( rtsUnitId )+import Type     ( Type, tyConAppTyCon )+import TyCon+import CLabel+import CmmUtils+import PrimOp+import SMRep+import FastString+import Outputable+import Util+import Data.Maybe++import Data.Bits ((.&.), bit)+import Control.Monad (liftM, when, unless)++------------------------------------------------------------------------+--      Primitive operations and foreign calls+------------------------------------------------------------------------++{- Note [Foreign call results]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~+A foreign call always returns an unboxed tuple of results, one+of which is the state token.  This seems to happen even for pure+calls.++Even if we returned a single result for pure calls, it'd still be+right to wrap it in a singleton unboxed tuple, because the result+might be a Haskell closure pointer, we don't want to evaluate it. -}++----------------------------------+cgOpApp :: StgOp        -- The op+        -> [StgArg]     -- Arguments+        -> Type         -- Result type (always an unboxed tuple)+        -> FCode ReturnKind++-- Foreign calls+cgOpApp (StgFCallOp fcall ty) stg_args res_ty+  = cgForeignCall fcall ty stg_args res_ty+      -- Note [Foreign call results]++cgOpApp (StgPrimOp primop) args res_ty = do+    dflags <- getDynFlags+    cmm_args <- getNonVoidArgAmodes args+    case emitPrimOp dflags primop cmm_args of+        PrimopCmmEmit_External -> do  -- out-of-line+          let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))+          emitCall (NativeNodeCall, NativeReturn) fun cmm_args++        PrimopCmmEmit_Raw f -> do+          exprs <- f res_ty+          emitReturn exprs++        PrimopCmmEmit_IntoRegs f  -- inline+          | ReturnsPrim VoidRep <- result_info+          -> do f []+                emitReturn []++          | ReturnsPrim rep <- result_info+          -> do dflags <- getDynFlags+                res <- newTemp (primRepCmmType dflags rep)+                f [res]+                emitReturn [CmmReg (CmmLocal res)]++          | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon+          -> do (regs, _hints) <- newUnboxedTupleRegs res_ty+                f regs+                emitReturn (map (CmmReg . CmmLocal) regs)++          | otherwise -> panic "cgPrimop"+          where+             result_info = getPrimOpResultInfo primop++cgOpApp (StgPrimCallOp primcall) args _res_ty+  = do  { cmm_args <- getNonVoidArgAmodes args+        ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))+        ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }++-- | Interpret the argument as an unsigned value, assuming the value+-- is given in two-complement form in the given width.+--+-- Example: @asUnsigned W64 (-1)@ is 18446744073709551615.+--+-- This function is used to work around the fact that many array+-- primops take Int# arguments, but we interpret them as unsigned+-- quantities in the code gen. This means that we have to be careful+-- every time we work on e.g. a CmmInt literal that corresponds to the+-- array size, as it might contain a negative Integer value if the+-- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int#+-- literal.+asUnsigned :: Width -> Integer -> Integer+asUnsigned w n = n .&. (bit (widthInBits w) - 1)++---------------------------------------------------+cgPrimOp   :: [LocalReg]        -- where to put the results+           -> PrimOp            -- the op+           -> [StgArg]          -- arguments+           -> FCode ()++cgPrimOp results op args = do+  dflags <- getDynFlags+  arg_exprs <- getNonVoidArgAmodes args+  case emitPrimOp dflags op arg_exprs of+    PrimopCmmEmit_External -> panic "External prim op"+    PrimopCmmEmit_Raw _ -> panic "caller should handle TagToEnum themselves"+    PrimopCmmEmit_IntoRegs f -> f results+++------------------------------------------------------------------------+--      Emitting code for a primop+------------------------------------------------------------------------++shouldInlinePrimOp :: DynFlags -> PrimOp -> [CmmExpr] -> Bool+shouldInlinePrimOp dflags op args = case emitPrimOp dflags op args of+  PrimopCmmEmit_External -> False+  PrimopCmmEmit_IntoRegs _ -> True+  PrimopCmmEmit_Raw _ -> True++-- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use+-- ByteOff (or some other fixed width signed type) to represent+-- array sizes or indices. This means that these will overflow for+-- large enough sizes.++-- TODO: Several primops, such as 'copyArray#', only have an inline+-- implementation (below) but could possibly have both an inline+-- implementation and an out-of-line implementation, just like+-- 'newArray#'. This would lower the amount of code generated,+-- hopefully without a performance impact (needs to be measured).++-- | The big function handling all the primops.+--+-- In the simple case, there is just one implementation, and we emit that.+--+-- In more complex cases, there is a foreign call (out of line) fallback. This+-- might happen e.g. if there's enough static information, such as statically+-- know arguments.+emitPrimOp+  :: DynFlags+  -> PrimOp            -- ^ The primop+  -> [CmmExpr]         -- ^ The primop arguments+  -> PrimopCmmEmit+emitPrimOp dflags = \case+  NewByteArrayOp_Char -> \case+    [(CmmLit (CmmInt n w))]+      | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags)+      -> opAllDone  $ \ [res] -> doNewByteArrayOp res (fromInteger n)+    _ -> PrimopCmmEmit_External++  NewArrayOp -> \case+    [(CmmLit (CmmInt n w)), init]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opAllDone $ \[res] -> doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel+        [ (mkIntExpr dflags (fromInteger n),+           fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags)+        , (mkIntExpr dflags (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))),+           fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags)+        ]+        (fromInteger n) init+    _ -> PrimopCmmEmit_External++  CopyArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      opAllDone $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CopyMutableArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      opAllDone $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CopyArrayArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      opAllDone $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CopyMutableArrayArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      opAllDone $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CloneArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opAllDone $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CloneMutableArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opAllDone $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  FreezeArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opAllDone $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  ThawArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opAllDone $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  NewSmallArrayOp -> \case+    [(CmmLit (CmmInt n w)), init]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opAllDone $ \ [res] ->+        doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel+        [ (mkIntExpr dflags (fromInteger n),+           fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags)+        ]+        (fromInteger n) init+    _ -> PrimopCmmEmit_External++  CopySmallArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      opAllDone $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CopySmallMutableArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      opAllDone $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CloneSmallArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CloneSmallMutableArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  FreezeSmallArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  ThawSmallArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++-- First we handle various awkward cases specially.++  ParOp -> \[arg] -> opAllDone $ \[res] -> do+    -- for now, just implement this in a C function+    -- later, we might want to inline it.+    emitCCall+        [(res,NoHint)]+        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))+        [(baseExpr, AddrHint), (arg,AddrHint)]++  SparkOp -> \[arg] -> opAllDone $ \[res] -> do+    -- returns the value of arg in res.  We're going to therefore+    -- refer to arg twice (once to pass to newSpark(), and once to+    -- assign to res), so put it in a temporary.+    tmp <- assignTemp arg+    tmp2 <- newTemp (bWord dflags)+    emitCCall+        [(tmp2,NoHint)]+        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))+        [(baseExpr, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]+    emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))++  GetCCSOfOp -> \[arg] -> opAllDone $ \[res] -> do+    let+      val+       | gopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg)+       | otherwise                      = CmmLit (zeroCLit dflags)+    emitAssign (CmmLocal res) val++  GetCurrentCCSOp -> \[_] -> opAllDone $ \[res] -> do+    emitAssign (CmmLocal res) cccsExpr++  MyThreadIdOp -> \[] -> opAllDone $ \[res] -> do+    emitAssign (CmmLocal res) currentTSOExpr++  ReadMutVarOp -> \[mutv] -> opAllDone $ \[res] -> do+    emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))++  WriteMutVarOp -> \[mutv, var] -> opAllDone $ \res@[] -> do+    old_val <- CmmLocal <$> newTemp (cmmExprType dflags var)+    emitAssign old_val (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))++    -- Without this write barrier, other CPUs may see this pointer before+    -- the writes for the closure it points to have occurred.+    -- Note that this also must come after we read the old value to ensure+    -- that the read of old_val comes before another core's write to the+    -- MutVar's value.+    emitPrimCall res MO_WriteBarrier []+    emitStore (cmmOffsetW dflags mutv (fixedHdrSizeW dflags)) var+    emitCCall+            [{-no results-}]+            (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))+            [(baseExpr, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)]++--  #define sizzeofByteArrayzh(r,a) \+--     r = ((StgArrBytes *)(a))->bytes+  SizeofByteArrayOp -> \[arg] -> opAllDone $ \[res] -> do+    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))++--  #define sizzeofMutableByteArrayzh(r,a) \+--      r = ((StgArrBytes *)(a))->bytes+  SizeofMutableByteArrayOp -> emitPrimOp dflags SizeofByteArrayOp++--  #define getSizzeofMutableByteArrayzh(r,a) \+--      r = ((StgArrBytes *)(a))->bytes+  GetSizeofMutableByteArrayOp -> \[arg] -> opAllDone $ \[res] -> do+    emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))+++--  #define touchzh(o)                  /* nothing */+  TouchOp -> \args@[_] -> opAllDone $ \res@[] -> do+    emitPrimCall res MO_Touch args++--  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)+  ByteArrayContents_Char -> \[arg] -> opAllDone $ \[res] -> do+    emitAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags))++--  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)+  StableNameToIntOp -> \[arg] -> opAllDone $ \[res] -> do+    emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))++  ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opAllDone $ \[res] -> do+    emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])++--  #define addrToHValuezh(r,a) r=(P_)a+  AddrToAnyOp -> \[arg] -> opAllDone $ \[res] -> do+    emitAssign (CmmLocal res) arg++--  #define hvalueToAddrzh(r, a) r=(W_)a+  AnyToAddrOp -> \[arg] -> opAllDone $ \[res] -> do+    emitAssign (CmmLocal res) arg++{- Freezing arrays-of-ptrs requires changing an info table, for the+   benefit of the generational collector.  It needs to scavenge mutable+   objects, even if they are in old space.  When they become immutable,+   they can be removed from this scavenge list.  -}++--  #define unsafeFreezzeArrayzh(r,a)+--      {+--        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info);+--        r = a;+--      }+  UnsafeFreezeArrayOp -> \[arg] -> opAllDone $ \[res] -> do+    emit $ catAGraphs+      [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),+        mkAssign (CmmLocal res) arg ]+  UnsafeFreezeArrayArrayOp -> \[arg] -> opAllDone $ \[res] -> do+    emit $ catAGraphs+      [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),+        mkAssign (CmmLocal res) arg ]+  UnsafeFreezeSmallArrayOp -> \[arg] -> opAllDone $ \[res] -> do+    emit $ catAGraphs+      [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)),+        mkAssign (CmmLocal res) arg ]++--  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)+  UnsafeFreezeByteArrayOp -> \[arg] -> opAllDone $ \[res] -> do+    emitAssign (CmmLocal res) arg++-- Reading/writing pointer arrays++  ReadArrayOp -> \[obj, ix] -> opAllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  IndexArrayOp -> \[obj, ix] -> opAllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  WriteArrayOp -> \[obj, ix, v] -> opAllDone $ \[] -> do+    doWritePtrArrayOp obj ix v++  IndexArrayArrayOp_ByteArray -> \[obj, ix] -> opAllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  IndexArrayArrayOp_ArrayArray -> \[obj, ix] -> opAllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  ReadArrayArrayOp_ByteArray -> \[obj, ix] -> opAllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  ReadArrayArrayOp_MutableByteArray -> \[obj, ix] -> opAllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  ReadArrayArrayOp_ArrayArray -> \[obj, ix] -> opAllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  ReadArrayArrayOp_MutableArrayArray -> \[obj, ix] -> opAllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  WriteArrayArrayOp_ByteArray -> \[obj,ix,v] -> opAllDone $ \[] -> do+    doWritePtrArrayOp obj ix v+  WriteArrayArrayOp_MutableByteArray -> \[obj,ix,v] -> opAllDone $ \[] -> do+    doWritePtrArrayOp obj ix v+  WriteArrayArrayOp_ArrayArray -> \[obj,ix,v] -> opAllDone $ \[] -> do+    doWritePtrArrayOp obj ix v+  WriteArrayArrayOp_MutableArrayArray -> \[obj,ix,v] -> opAllDone $ \[] -> do+    doWritePtrArrayOp obj ix v++  ReadSmallArrayOp -> \[obj, ix] -> opAllDone $ \[res] -> do+    doReadSmallPtrArrayOp res obj ix+  IndexSmallArrayOp -> \[obj, ix] -> opAllDone $ \[res] -> do+    doReadSmallPtrArrayOp res obj ix+  WriteSmallArrayOp -> \[obj,ix,v] -> opAllDone $ \[] -> do+    doWriteSmallPtrArrayOp obj ix v++-- Getting the size of pointer arrays++  SizeofArrayOp -> \[arg] -> opAllDone $ \[res] -> do+    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg+      (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgMutArrPtrs_ptrs dflags))+        (bWord dflags))+  SizeofMutableArrayOp -> emitPrimOp dflags SizeofArrayOp+  SizeofArrayArrayOp -> emitPrimOp dflags SizeofArrayOp+  SizeofMutableArrayArrayOp -> emitPrimOp dflags SizeofArrayOp+  SizeofSmallArrayOp -> \[arg] -> opAllDone $ \[res] -> do+    emit $ mkAssign (CmmLocal res)+     (cmmLoadIndexW dflags arg+     (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgSmallMutArrPtrs_ptrs dflags))+        (bWord dflags))++  SizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp+  GetSizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp++-- IndexXXXoffAddr++  IndexOffAddrOp_Char -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args+  IndexOffAddrOp_WideChar -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+  IndexOffAddrOp_Int -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  IndexOffAddrOp_Word -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  IndexOffAddrOp_Addr -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  IndexOffAddrOp_Float -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing f32 res args+  IndexOffAddrOp_Double -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing f64 res args+  IndexOffAddrOp_StablePtr -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  IndexOffAddrOp_Int8 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args+  IndexOffAddrOp_Int16 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args+  IndexOffAddrOp_Int32 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args+  IndexOffAddrOp_Int64 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing b64 res args+  IndexOffAddrOp_Word8 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args+  IndexOffAddrOp_Word16 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args+  IndexOffAddrOp_Word32 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+  IndexOffAddrOp_Word64 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing b64 res args++-- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.++  ReadOffAddrOp_Char -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args+  ReadOffAddrOp_WideChar -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+  ReadOffAddrOp_Int -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  ReadOffAddrOp_Word -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  ReadOffAddrOp_Addr -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  ReadOffAddrOp_Float -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing f32 res args+  ReadOffAddrOp_Double -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing f64 res args+  ReadOffAddrOp_StablePtr -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  ReadOffAddrOp_Int8 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args+  ReadOffAddrOp_Int16 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args+  ReadOffAddrOp_Int32 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args+  ReadOffAddrOp_Int64 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing b64 res args+  ReadOffAddrOp_Word8 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args+  ReadOffAddrOp_Word16 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args+  ReadOffAddrOp_Word32 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+  ReadOffAddrOp_Word64 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing b64 res args++-- IndexXXXArray++  IndexByteArrayOp_Char -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args+  IndexByteArrayOp_WideChar -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args+  IndexByteArrayOp_Int -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  IndexByteArrayOp_Word -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  IndexByteArrayOp_Addr -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  IndexByteArrayOp_Float -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing f32 res args+  IndexByteArrayOp_Double -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing f64 res args+  IndexByteArrayOp_StablePtr -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  IndexByteArrayOp_Int8 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args+  IndexByteArrayOp_Int16 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args+  IndexByteArrayOp_Int32 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args+  IndexByteArrayOp_Int64 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing b64  res args+  IndexByteArrayOp_Word8 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args+  IndexByteArrayOp_Word16 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args+  IndexByteArrayOp_Word32 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args+  IndexByteArrayOp_Word64 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing b64  res args++-- ReadXXXArray, identical to IndexXXXArray.++  ReadByteArrayOp_Char -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args+  ReadByteArrayOp_WideChar -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args+  ReadByteArrayOp_Int -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  ReadByteArrayOp_Word -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  ReadByteArrayOp_Addr -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  ReadByteArrayOp_Float -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing f32 res args+  ReadByteArrayOp_Double -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing f64 res args+  ReadByteArrayOp_StablePtr -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  ReadByteArrayOp_Int8 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args+  ReadByteArrayOp_Int16 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args+  ReadByteArrayOp_Int32 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args+  ReadByteArrayOp_Int64 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing b64  res args+  ReadByteArrayOp_Word8 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args+  ReadByteArrayOp_Word16 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args+  ReadByteArrayOp_Word32 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args+  ReadByteArrayOp_Word64 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing b64  res args++-- IndexWord8ArrayAsXXX++  IndexByteArrayOp_Word8AsChar -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args+  IndexByteArrayOp_Word8AsWideChar -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+  IndexByteArrayOp_Word8AsInt -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  IndexByteArrayOp_Word8AsWord -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  IndexByteArrayOp_Word8AsAddr -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  IndexByteArrayOp_Word8AsFloat -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing f32 b8 res args+  IndexByteArrayOp_Word8AsDouble -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing f64 b8 res args+  IndexByteArrayOp_Word8AsStablePtr -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  IndexByteArrayOp_Word8AsInt16 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args+  IndexByteArrayOp_Word8AsInt32 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args+  IndexByteArrayOp_Word8AsInt64 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing b64 b8 res args+  IndexByteArrayOp_Word8AsWord16 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args+  IndexByteArrayOp_Word8AsWord32 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+  IndexByteArrayOp_Word8AsWord64 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing b64 b8 res args++-- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX++  ReadByteArrayOp_Word8AsChar -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args+  ReadByteArrayOp_Word8AsWideChar -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+  ReadByteArrayOp_Word8AsInt -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  ReadByteArrayOp_Word8AsWord -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  ReadByteArrayOp_Word8AsAddr -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  ReadByteArrayOp_Word8AsFloat -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing f32 b8 res args+  ReadByteArrayOp_Word8AsDouble -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing f64 b8 res args+  ReadByteArrayOp_Word8AsStablePtr -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  ReadByteArrayOp_Word8AsInt16 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args+  ReadByteArrayOp_Word8AsInt32 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args+  ReadByteArrayOp_Word8AsInt64 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing b64 b8 res args+  ReadByteArrayOp_Word8AsWord16 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args+  ReadByteArrayOp_Word8AsWord32 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+  ReadByteArrayOp_Word8AsWord64 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing b64 b8 res args++-- WriteXXXoffAddr++  WriteOffAddrOp_Char -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args+  WriteOffAddrOp_WideChar -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args+  WriteOffAddrOp_Int -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp Nothing (bWord dflags) res args+  WriteOffAddrOp_Word -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp Nothing (bWord dflags) res args+  WriteOffAddrOp_Addr -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp Nothing (bWord dflags) res args+  WriteOffAddrOp_Float -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp Nothing f32 res args+  WriteOffAddrOp_Double -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp Nothing f64 res args+  WriteOffAddrOp_StablePtr -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp Nothing (bWord dflags) res args+  WriteOffAddrOp_Int8 -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args+  WriteOffAddrOp_Int16 -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args+  WriteOffAddrOp_Int32 -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args+  WriteOffAddrOp_Int64 -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp Nothing b64 res args+  WriteOffAddrOp_Word8 -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args+  WriteOffAddrOp_Word16 -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args+  WriteOffAddrOp_Word32 -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args+  WriteOffAddrOp_Word64 -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp Nothing b64 res args++-- WriteXXXArray++  WriteByteArrayOp_Char -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args+  WriteByteArrayOp_WideChar -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args+  WriteByteArrayOp_Int -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing (bWord dflags) res args+  WriteByteArrayOp_Word -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing (bWord dflags) res args+  WriteByteArrayOp_Addr -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing (bWord dflags) res args+  WriteByteArrayOp_Float -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing f32 res args+  WriteByteArrayOp_Double -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing f64 res args+  WriteByteArrayOp_StablePtr -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing (bWord dflags) res args+  WriteByteArrayOp_Int8 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args+  WriteByteArrayOp_Int16 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args+  WriteByteArrayOp_Int32 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args+  WriteByteArrayOp_Int64 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing b64 res args+  WriteByteArrayOp_Word8 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8  res args+  WriteByteArrayOp_Word16 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args+  WriteByteArrayOp_Word32 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args+  WriteByteArrayOp_Word64 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing b64 res args++-- WriteInt8ArrayAsXXX++  WriteByteArrayOp_Word8AsChar -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args+  WriteByteArrayOp_Word8AsWideChar -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args+  WriteByteArrayOp_Word8AsInt -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsWord -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsAddr -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsFloat -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsDouble -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsStablePtr -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsInt16 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args+  WriteByteArrayOp_Word8AsInt32 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args+  WriteByteArrayOp_Word8AsInt64 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsWord16 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args+  WriteByteArrayOp_Word8AsWord32 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args+  WriteByteArrayOp_Word8AsWord64 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args++-- Copying and setting byte arrays+  CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opAllDone $ \[] -> do+    doCopyByteArrayOp src src_off dst dst_off n+  CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opAllDone $ \[] -> do+    doCopyMutableByteArrayOp src src_off dst dst_off n+  CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> opAllDone $ \[] -> do+    doCopyByteArrayToAddrOp src src_off dst n+  CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> opAllDone $ \[] -> do+    doCopyMutableByteArrayToAddrOp src src_off dst n+  CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> opAllDone $ \[] -> do+    doCopyAddrToByteArrayOp src dst dst_off n+  SetByteArrayOp -> \[ba,off,len,c] -> opAllDone $ \[] -> do+    doSetByteArrayOp ba off len c++-- Comparing byte arrays+  CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> opAllDone $ \[res] -> do+    doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n++  BSwap16Op -> \[w] -> opAllDone $ \[res] -> do+    emitBSwapCall res w W16+  BSwap32Op -> \[w] -> opAllDone $ \[res] -> do+    emitBSwapCall res w W32+  BSwap64Op -> \[w] -> opAllDone $ \[res] -> do+    emitBSwapCall res w W64+  BSwapOp -> \[w] -> opAllDone $ \[res] -> do+    emitBSwapCall res w (wordWidth dflags)++  BRev8Op -> \[w] -> opAllDone $ \[res] -> do+    emitBRevCall res w W8+  BRev16Op -> \[w] -> opAllDone $ \[res] -> do+    emitBRevCall res w W16+  BRev32Op -> \[w] -> opAllDone $ \[res] -> do+    emitBRevCall res w W32+  BRev64Op -> \[w] -> opAllDone $ \[res] -> do+    emitBRevCall res w W64+  BRevOp -> \[w] -> opAllDone $ \[res] -> do+    emitBRevCall res w (wordWidth dflags)++-- Population count+  PopCnt8Op -> \[w] -> opAllDone $ \[res] -> do+    emitPopCntCall res w W8+  PopCnt16Op -> \[w] -> opAllDone $ \[res] -> do+    emitPopCntCall res w W16+  PopCnt32Op -> \[w] -> opAllDone $ \[res] -> do+    emitPopCntCall res w W32+  PopCnt64Op -> \[w] -> opAllDone $ \[res] -> do+    emitPopCntCall res w W64+  PopCntOp -> \[w] -> opAllDone $ \[res] -> do+    emitPopCntCall res w (wordWidth dflags)++-- Parallel bit deposit+  Pdep8Op -> \[src, mask] -> opAllDone $ \[res] -> do+    emitPdepCall res src mask W8+  Pdep16Op -> \[src, mask] -> opAllDone $ \[res] -> do+    emitPdepCall res src mask W16+  Pdep32Op -> \[src, mask] -> opAllDone $ \[res] -> do+    emitPdepCall res src mask W32+  Pdep64Op -> \[src, mask] -> opAllDone $ \[res] -> do+    emitPdepCall res src mask W64+  PdepOp -> \[src, mask] -> opAllDone $ \[res] -> do+    emitPdepCall res src mask (wordWidth dflags)++-- Parallel bit extract+  Pext8Op -> \[src, mask] -> opAllDone $ \[res] -> do+    emitPextCall res src mask W8+  Pext16Op -> \[src, mask] -> opAllDone $ \[res] -> do+    emitPextCall res src mask W16+  Pext32Op -> \[src, mask] -> opAllDone $ \[res] -> do+    emitPextCall res src mask W32+  Pext64Op -> \[src, mask] -> opAllDone $ \[res] -> do+    emitPextCall res src mask W64+  PextOp -> \[src, mask] -> opAllDone $ \[res] -> do+    emitPextCall res src mask (wordWidth dflags)++-- count leading zeros+  Clz8Op -> \[w] -> opAllDone $ \[res] -> do+    emitClzCall res w W8+  Clz16Op -> \[w] -> opAllDone $ \[res] -> do+    emitClzCall res w W16+  Clz32Op -> \[w] -> opAllDone $ \[res] -> do+    emitClzCall res w W32+  Clz64Op -> \[w] -> opAllDone $ \[res] -> do+    emitClzCall res w W64+  ClzOp -> \[w] -> opAllDone $ \[res] -> do+    emitClzCall res w (wordWidth dflags)++-- count trailing zeros+  Ctz8Op -> \[w] -> opAllDone $ \[res] -> do+    emitCtzCall res w W8+  Ctz16Op -> \[w] -> opAllDone $ \[res] -> do+    emitCtzCall res w W16+  Ctz32Op -> \[w] -> opAllDone $ \[res] -> do+    emitCtzCall res w W32+  Ctz64Op -> \[w] -> opAllDone $ \[res] -> do+    emitCtzCall res w W64+  CtzOp -> \[w] -> opAllDone $ \[res] -> do+    emitCtzCall res w (wordWidth dflags)++-- Unsigned int to floating point conversions+  Word2FloatOp -> \[w] -> opAllDone $ \[res] -> do+    emitPrimCall [res] (MO_UF_Conv W32) [w]+  Word2DoubleOp -> \[w] -> opAllDone $ \[res] -> do+    emitPrimCall [res] (MO_UF_Conv W64) [w]++-- SIMD primops+  (VecBroadcastOp vcat n w) -> \[e] -> opAllDone $ \[res] -> do+    checkVecCompatibility dflags vcat n w+    doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros (replicate n e) res+   where+    zeros :: CmmExpr+    zeros = CmmLit $ CmmVec (replicate n zero)++    zero :: CmmLit+    zero = case vcat of+             IntVec   -> CmmInt 0 w+             WordVec  -> CmmInt 0 w+             FloatVec -> CmmFloat 0 w++    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecPackOp vcat n w) -> \es -> opAllDone $ \[res] -> do+    checkVecCompatibility dflags vcat n w+    when (es `lengthIsNot` n) $+        panic "emitPrimOp: VecPackOp has wrong number of arguments"+    doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros es res+   where+    zeros :: CmmExpr+    zeros = CmmLit $ CmmVec (replicate n zero)++    zero :: CmmLit+    zero = case vcat of+             IntVec   -> CmmInt 0 w+             WordVec  -> CmmInt 0 w+             FloatVec -> CmmFloat 0 w++    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecUnpackOp vcat n w) -> \[arg] -> opAllDone $ \res -> do+    checkVecCompatibility dflags vcat n w+    when (res `lengthIsNot` n) $+        panic "emitPrimOp: VecUnpackOp has wrong number of results"+    doVecUnpackOp (vecElemProjectCast dflags vcat w) ty arg res+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecInsertOp vcat n w) -> \[v,e,i] -> opAllDone $ \[res] -> do+    checkVecCompatibility dflags vcat n w+    doVecInsertOp (vecElemInjectCast dflags vcat w) ty v e i res+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecIndexByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecReadByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecWriteByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doWriteByteArrayOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecIndexOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecReadOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecWriteOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doWriteOffAddrOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecIndexScalarByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOpAs Nothing vecty ty res0 args+   where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++  (VecReadScalarByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOpAs Nothing vecty ty res0 args+   where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++  (VecWriteScalarByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doWriteByteArrayOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecCmmCat vcat w++  (VecIndexScalarOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOpAs Nothing vecty ty res0 args+   where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++  (VecReadScalarOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOpAs Nothing vecty ty res0 args+   where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++  (VecWriteScalarOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doWriteOffAddrOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecCmmCat vcat w++-- Prefetch+  PrefetchByteArrayOp3         -> \args -> opAllDone $ \[] -> do+    doPrefetchByteArrayOp 3  args+  PrefetchMutableByteArrayOp3  -> \args -> opAllDone $ \[] -> do+    doPrefetchMutableByteArrayOp 3  args+  PrefetchAddrOp3              -> \args -> opAllDone $ \[] -> do+    doPrefetchAddrOp  3  args+  PrefetchValueOp3             -> \args -> opAllDone $ \[] -> do+    doPrefetchValueOp 3 args++  PrefetchByteArrayOp2         -> \args -> opAllDone $ \[] -> do+    doPrefetchByteArrayOp 2  args+  PrefetchMutableByteArrayOp2  -> \args -> opAllDone $ \[] -> do+    doPrefetchMutableByteArrayOp 2  args+  PrefetchAddrOp2              -> \args -> opAllDone $ \[] -> do+    doPrefetchAddrOp 2  args+  PrefetchValueOp2             -> \args -> opAllDone $ \[] -> do+    doPrefetchValueOp 2 args+  PrefetchByteArrayOp1         -> \args -> opAllDone $ \[] -> do+    doPrefetchByteArrayOp 1  args+  PrefetchMutableByteArrayOp1  -> \args -> opAllDone $ \[] -> do+    doPrefetchMutableByteArrayOp 1  args+  PrefetchAddrOp1              -> \args -> opAllDone $ \[] -> do+    doPrefetchAddrOp 1  args+  PrefetchValueOp1             -> \args -> opAllDone $ \[] -> do+    doPrefetchValueOp 1 args++  PrefetchByteArrayOp0         -> \args -> opAllDone $ \[] -> do+    doPrefetchByteArrayOp 0  args+  PrefetchMutableByteArrayOp0  -> \args -> opAllDone $ \[] -> do+    doPrefetchMutableByteArrayOp 0  args+  PrefetchAddrOp0              -> \args -> opAllDone $ \[] -> do+    doPrefetchAddrOp 0  args+  PrefetchValueOp0             -> \args -> opAllDone $ \[] -> do+    doPrefetchValueOp 0 args++-- Atomic read-modify-write+  FetchAddByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do+    doAtomicRMW res AMO_Add mba ix (bWord dflags) n+  FetchSubByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do+    doAtomicRMW res AMO_Sub mba ix (bWord dflags) n+  FetchAndByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do+    doAtomicRMW res AMO_And mba ix (bWord dflags) n+  FetchNandByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do+    doAtomicRMW res AMO_Nand mba ix (bWord dflags) n+  FetchOrByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do+    doAtomicRMW res AMO_Or mba ix (bWord dflags) n+  FetchXorByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do+    doAtomicRMW res AMO_Xor mba ix (bWord dflags) n+  AtomicReadByteArrayOp_Int -> \[mba, ix] -> opAllDone $ \[res] -> do+    doAtomicReadByteArray res mba ix (bWord dflags)+  AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> opAllDone $ \[] -> do+    doAtomicWriteByteArray mba ix (bWord dflags) val+  CasByteArrayOp_Int -> \[mba, ix, old, new] -> opAllDone $ \[res] -> do+    doCasByteArray res mba ix (bWord dflags) old new++-- The rest just translate straightforwardly++  Int2WordOp      -> \args -> opNop args+  Word2IntOp      -> \args -> opNop args+  Int2AddrOp      -> \args -> opNop args+  Addr2IntOp      -> \args -> opNop args+  ChrOp           -> \args -> opNop args  -- Int# and Char# are rep'd the same+  OrdOp           -> \args -> opNop args++  Narrow8IntOp   -> \args -> opNarrow dflags args (MO_SS_Conv, W8)+  Narrow16IntOp  -> \args -> opNarrow dflags args (MO_SS_Conv, W16)+  Narrow32IntOp  -> \args -> opNarrow dflags args (MO_SS_Conv, W32)+  Narrow8WordOp  -> \args -> opNarrow dflags args (MO_UU_Conv, W8)+  Narrow16WordOp -> \args -> opNarrow dflags args (MO_UU_Conv, W16)+  Narrow32WordOp -> \args -> opNarrow dflags args (MO_UU_Conv, W32)++  DoublePowerOp  -> \args -> opCallish args MO_F64_Pwr+  DoubleSinOp    -> \args -> opCallish args MO_F64_Sin+  DoubleCosOp    -> \args -> opCallish args MO_F64_Cos+  DoubleTanOp    -> \args -> opCallish args MO_F64_Tan+  DoubleSinhOp   -> \args -> opCallish args MO_F64_Sinh+  DoubleCoshOp   -> \args -> opCallish args MO_F64_Cosh+  DoubleTanhOp   -> \args -> opCallish args MO_F64_Tanh+  DoubleAsinOp   -> \args -> opCallish args MO_F64_Asin+  DoubleAcosOp   -> \args -> opCallish args MO_F64_Acos+  DoubleAtanOp   -> \args -> opCallish args MO_F64_Atan+  DoubleAsinhOp  -> \args -> opCallish args MO_F64_Asinh+  DoubleAcoshOp  -> \args -> opCallish args MO_F64_Acosh+  DoubleAtanhOp  -> \args -> opCallish args MO_F64_Atanh+  DoubleLogOp    -> \args -> opCallish args MO_F64_Log+  DoubleLog1POp  -> \args -> opCallish args MO_F64_Log1P+  DoubleExpOp    -> \args -> opCallish args MO_F64_Exp+  DoubleExpM1Op  -> \args -> opCallish args MO_F64_ExpM1+  DoubleSqrtOp   -> \args -> opCallish args MO_F64_Sqrt++  FloatPowerOp   -> \args -> opCallish args MO_F32_Pwr+  FloatSinOp     -> \args -> opCallish args MO_F32_Sin+  FloatCosOp     -> \args -> opCallish args MO_F32_Cos+  FloatTanOp     -> \args -> opCallish args MO_F32_Tan+  FloatSinhOp    -> \args -> opCallish args MO_F32_Sinh+  FloatCoshOp    -> \args -> opCallish args MO_F32_Cosh+  FloatTanhOp    -> \args -> opCallish args MO_F32_Tanh+  FloatAsinOp    -> \args -> opCallish args MO_F32_Asin+  FloatAcosOp    -> \args -> opCallish args MO_F32_Acos+  FloatAtanOp    -> \args -> opCallish args MO_F32_Atan+  FloatAsinhOp   -> \args -> opCallish args MO_F32_Asinh+  FloatAcoshOp   -> \args -> opCallish args MO_F32_Acosh+  FloatAtanhOp   -> \args -> opCallish args MO_F32_Atanh+  FloatLogOp     -> \args -> opCallish args MO_F32_Log+  FloatLog1POp   -> \args -> opCallish args MO_F32_Log1P+  FloatExpOp     -> \args -> opCallish args MO_F32_Exp+  FloatExpM1Op   -> \args -> opCallish args MO_F32_ExpM1+  FloatSqrtOp    -> \args -> opCallish args MO_F32_Sqrt++-- Native word signless ops++  IntAddOp       -> \args -> opTranslate args (mo_wordAdd dflags)+  IntSubOp       -> \args -> opTranslate args (mo_wordSub dflags)+  WordAddOp      -> \args -> opTranslate args (mo_wordAdd dflags)+  WordSubOp      -> \args -> opTranslate args (mo_wordSub dflags)+  AddrAddOp      -> \args -> opTranslate args (mo_wordAdd dflags)+  AddrSubOp      -> \args -> opTranslate args (mo_wordSub dflags)++  IntEqOp        -> \args -> opTranslate args (mo_wordEq dflags)+  IntNeOp        -> \args -> opTranslate args (mo_wordNe dflags)+  WordEqOp       -> \args -> opTranslate args (mo_wordEq dflags)+  WordNeOp       -> \args -> opTranslate args (mo_wordNe dflags)+  AddrEqOp       -> \args -> opTranslate args (mo_wordEq dflags)+  AddrNeOp       -> \args -> opTranslate args (mo_wordNe dflags)++  AndOp          -> \args -> opTranslate args (mo_wordAnd dflags)+  OrOp           -> \args -> opTranslate args (mo_wordOr dflags)+  XorOp          -> \args -> opTranslate args (mo_wordXor dflags)+  NotOp          -> \args -> opTranslate args (mo_wordNot dflags)+  SllOp          -> \args -> opTranslate args (mo_wordShl dflags)+  SrlOp          -> \args -> opTranslate args (mo_wordUShr dflags)++  AddrRemOp      -> \args -> opTranslate args (mo_wordURem dflags)++-- Native word signed ops++  IntMulOp        -> \args -> opTranslate args (mo_wordMul dflags)+  IntMulMayOfloOp -> \args -> opTranslate args (MO_S_MulMayOflo (wordWidth dflags))+  IntQuotOp       -> \args -> opTranslate args (mo_wordSQuot dflags)+  IntRemOp        -> \args -> opTranslate args (mo_wordSRem dflags)+  IntNegOp        -> \args -> opTranslate args (mo_wordSNeg dflags)++  IntGeOp        -> \args -> opTranslate args (mo_wordSGe dflags)+  IntLeOp        -> \args -> opTranslate args (mo_wordSLe dflags)+  IntGtOp        -> \args -> opTranslate args (mo_wordSGt dflags)+  IntLtOp        -> \args -> opTranslate args (mo_wordSLt dflags)++  AndIOp         -> \args -> opTranslate args (mo_wordAnd dflags)+  OrIOp          -> \args -> opTranslate args (mo_wordOr dflags)+  XorIOp         -> \args -> opTranslate args (mo_wordXor dflags)+  NotIOp         -> \args -> opTranslate args (mo_wordNot dflags)+  ISllOp         -> \args -> opTranslate args (mo_wordShl dflags)+  ISraOp         -> \args -> opTranslate args (mo_wordSShr dflags)+  ISrlOp         -> \args -> opTranslate args (mo_wordUShr dflags)++-- Native word unsigned ops++  WordGeOp       -> \args -> opTranslate args (mo_wordUGe dflags)+  WordLeOp       -> \args -> opTranslate args (mo_wordULe dflags)+  WordGtOp       -> \args -> opTranslate args (mo_wordUGt dflags)+  WordLtOp       -> \args -> opTranslate args (mo_wordULt dflags)++  WordMulOp      -> \args -> opTranslate args (mo_wordMul dflags)+  WordQuotOp     -> \args -> opTranslate args (mo_wordUQuot dflags)+  WordRemOp      -> \args -> opTranslate args (mo_wordURem dflags)++  AddrGeOp       -> \args -> opTranslate args (mo_wordUGe dflags)+  AddrLeOp       -> \args -> opTranslate args (mo_wordULe dflags)+  AddrGtOp       -> \args -> opTranslate args (mo_wordUGt dflags)+  AddrLtOp       -> \args -> opTranslate args (mo_wordULt dflags)++-- Int8# signed ops++  Int8Extend     -> \args -> opTranslate args (MO_SS_Conv W8 (wordWidth dflags))+  Int8Narrow     -> \args -> opTranslate args (MO_SS_Conv (wordWidth dflags) W8)+  Int8NegOp      -> \args -> opTranslate args (MO_S_Neg W8)+  Int8AddOp      -> \args -> opTranslate args (MO_Add W8)+  Int8SubOp      -> \args -> opTranslate args (MO_Sub W8)+  Int8MulOp      -> \args -> opTranslate args (MO_Mul W8)+  Int8QuotOp     -> \args -> opTranslate args (MO_S_Quot W8)+  Int8RemOp      -> \args -> opTranslate args (MO_S_Rem W8)++  Int8EqOp       -> \args -> opTranslate args (MO_Eq W8)+  Int8GeOp       -> \args -> opTranslate args (MO_S_Ge W8)+  Int8GtOp       -> \args -> opTranslate args (MO_S_Gt W8)+  Int8LeOp       -> \args -> opTranslate args (MO_S_Le W8)+  Int8LtOp       -> \args -> opTranslate args (MO_S_Lt W8)+  Int8NeOp       -> \args -> opTranslate args (MO_Ne W8)++-- Word8# unsigned ops++  Word8Extend     -> \args -> opTranslate args (MO_UU_Conv W8 (wordWidth dflags))+  Word8Narrow     -> \args -> opTranslate args (MO_UU_Conv (wordWidth dflags) W8)+  Word8NotOp      -> \args -> opTranslate args (MO_Not W8)+  Word8AddOp      -> \args -> opTranslate args (MO_Add W8)+  Word8SubOp      -> \args -> opTranslate args (MO_Sub W8)+  Word8MulOp      -> \args -> opTranslate args (MO_Mul W8)+  Word8QuotOp     -> \args -> opTranslate args (MO_U_Quot W8)+  Word8RemOp      -> \args -> opTranslate args (MO_U_Rem W8)++  Word8EqOp       -> \args -> opTranslate args (MO_Eq W8)+  Word8GeOp       -> \args -> opTranslate args (MO_U_Ge W8)+  Word8GtOp       -> \args -> opTranslate args (MO_U_Gt W8)+  Word8LeOp       -> \args -> opTranslate args (MO_U_Le W8)+  Word8LtOp       -> \args -> opTranslate args (MO_U_Lt W8)+  Word8NeOp       -> \args -> opTranslate args (MO_Ne W8)++-- Int16# signed ops++  Int16Extend     -> \args -> opTranslate args (MO_SS_Conv W16 (wordWidth dflags))+  Int16Narrow     -> \args -> opTranslate args (MO_SS_Conv (wordWidth dflags) W16)+  Int16NegOp      -> \args -> opTranslate args (MO_S_Neg W16)+  Int16AddOp      -> \args -> opTranslate args (MO_Add W16)+  Int16SubOp      -> \args -> opTranslate args (MO_Sub W16)+  Int16MulOp      -> \args -> opTranslate args (MO_Mul W16)+  Int16QuotOp     -> \args -> opTranslate args (MO_S_Quot W16)+  Int16RemOp      -> \args -> opTranslate args (MO_S_Rem W16)++  Int16EqOp       -> \args -> opTranslate args (MO_Eq W16)+  Int16GeOp       -> \args -> opTranslate args (MO_S_Ge W16)+  Int16GtOp       -> \args -> opTranslate args (MO_S_Gt W16)+  Int16LeOp       -> \args -> opTranslate args (MO_S_Le W16)+  Int16LtOp       -> \args -> opTranslate args (MO_S_Lt W16)+  Int16NeOp       -> \args -> opTranslate args (MO_Ne W16)++-- Word16# unsigned ops++  Word16Extend     -> \args -> opTranslate args (MO_UU_Conv W16 (wordWidth dflags))+  Word16Narrow     -> \args -> opTranslate args (MO_UU_Conv (wordWidth dflags) W16)+  Word16NotOp      -> \args -> opTranslate args (MO_Not W16)+  Word16AddOp      -> \args -> opTranslate args (MO_Add W16)+  Word16SubOp      -> \args -> opTranslate args (MO_Sub W16)+  Word16MulOp      -> \args -> opTranslate args (MO_Mul W16)+  Word16QuotOp     -> \args -> opTranslate args (MO_U_Quot W16)+  Word16RemOp      -> \args -> opTranslate args (MO_U_Rem W16)++  Word16EqOp       -> \args -> opTranslate args (MO_Eq W16)+  Word16GeOp       -> \args -> opTranslate args (MO_U_Ge W16)+  Word16GtOp       -> \args -> opTranslate args (MO_U_Gt W16)+  Word16LeOp       -> \args -> opTranslate args (MO_U_Le W16)+  Word16LtOp       -> \args -> opTranslate args (MO_U_Lt W16)+  Word16NeOp       -> \args -> opTranslate args (MO_Ne W16)++-- Char# ops++  CharEqOp       -> \args -> opTranslate args (MO_Eq (wordWidth dflags))+  CharNeOp       -> \args -> opTranslate args (MO_Ne (wordWidth dflags))+  CharGeOp       -> \args -> opTranslate args (MO_U_Ge (wordWidth dflags))+  CharLeOp       -> \args -> opTranslate args (MO_U_Le (wordWidth dflags))+  CharGtOp       -> \args -> opTranslate args (MO_U_Gt (wordWidth dflags))+  CharLtOp       -> \args -> opTranslate args (MO_U_Lt (wordWidth dflags))++-- Double ops++  DoubleEqOp     -> \args -> opTranslate args (MO_F_Eq W64)+  DoubleNeOp     -> \args -> opTranslate args (MO_F_Ne W64)+  DoubleGeOp     -> \args -> opTranslate args (MO_F_Ge W64)+  DoubleLeOp     -> \args -> opTranslate args (MO_F_Le W64)+  DoubleGtOp     -> \args -> opTranslate args (MO_F_Gt W64)+  DoubleLtOp     -> \args -> opTranslate args (MO_F_Lt W64)++  DoubleAddOp    -> \args -> opTranslate args (MO_F_Add W64)+  DoubleSubOp    -> \args -> opTranslate args (MO_F_Sub W64)+  DoubleMulOp    -> \args -> opTranslate args (MO_F_Mul W64)+  DoubleDivOp    -> \args -> opTranslate args (MO_F_Quot W64)+  DoubleNegOp    -> \args -> opTranslate args (MO_F_Neg W64)++-- Float ops++  FloatEqOp     -> \args -> opTranslate args (MO_F_Eq W32)+  FloatNeOp     -> \args -> opTranslate args (MO_F_Ne W32)+  FloatGeOp     -> \args -> opTranslate args (MO_F_Ge W32)+  FloatLeOp     -> \args -> opTranslate args (MO_F_Le W32)+  FloatGtOp     -> \args -> opTranslate args (MO_F_Gt W32)+  FloatLtOp     -> \args -> opTranslate args (MO_F_Lt W32)++  FloatAddOp    -> \args -> opTranslate args (MO_F_Add  W32)+  FloatSubOp    -> \args -> opTranslate args (MO_F_Sub  W32)+  FloatMulOp    -> \args -> opTranslate args (MO_F_Mul  W32)+  FloatDivOp    -> \args -> opTranslate args (MO_F_Quot W32)+  FloatNegOp    -> \args -> opTranslate args (MO_F_Neg  W32)++-- Vector ops++  (VecAddOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Add  n w)+  (VecSubOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Sub  n w)+  (VecMulOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Mul  n w)+  (VecDivOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Quot n w)+  (VecQuotOp FloatVec _ _) -> \_ -> panic "unsupported primop"+  (VecRemOp  FloatVec _ _) -> \_ -> panic "unsupported primop"+  (VecNegOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Neg  n w)++  (VecAddOp  IntVec n w) -> \args -> opTranslate args (MO_V_Add   n w)+  (VecSubOp  IntVec n w) -> \args -> opTranslate args (MO_V_Sub   n w)+  (VecMulOp  IntVec n w) -> \args -> opTranslate args (MO_V_Mul   n w)+  (VecDivOp  IntVec _ _) -> \_ -> panic "unsupported primop"+  (VecQuotOp IntVec n w) -> \args -> opTranslate args (MO_VS_Quot n w)+  (VecRemOp  IntVec n w) -> \args -> opTranslate args (MO_VS_Rem  n w)+  (VecNegOp  IntVec n w) -> \args -> opTranslate args (MO_VS_Neg  n w)++  (VecAddOp  WordVec n w) -> \args -> opTranslate args (MO_V_Add   n w)+  (VecSubOp  WordVec n w) -> \args -> opTranslate args (MO_V_Sub   n w)+  (VecMulOp  WordVec n w) -> \args -> opTranslate args (MO_V_Mul   n w)+  (VecDivOp  WordVec _ _) -> \_ -> panic "unsupported primop"+  (VecQuotOp WordVec n w) -> \args -> opTranslate args (MO_VU_Quot n w)+  (VecRemOp  WordVec n w) -> \args -> opTranslate args (MO_VU_Rem  n w)+  (VecNegOp  WordVec _ _) -> \_ -> panic "unsupported primop"++-- Conversions++  Int2DoubleOp   -> \args -> opTranslate args (MO_SF_Conv (wordWidth dflags) W64)+  Double2IntOp   -> \args -> opTranslate args (MO_FS_Conv W64 (wordWidth dflags))++  Int2FloatOp    -> \args -> opTranslate args (MO_SF_Conv (wordWidth dflags) W32)+  Float2IntOp    -> \args -> opTranslate args (MO_FS_Conv W32 (wordWidth dflags))++  Float2DoubleOp -> \args -> opTranslate args (MO_FF_Conv W32 W64)+  Double2FloatOp -> \args -> opTranslate args (MO_FF_Conv W64 W32)++-- Word comparisons masquerading as more exotic things.++  SameMutVarOp            -> \args -> opTranslate args (mo_wordEq dflags)+  SameMVarOp              -> \args -> opTranslate args (mo_wordEq dflags)+  SameMutableArrayOp      -> \args -> opTranslate args (mo_wordEq dflags)+  SameMutableByteArrayOp  -> \args -> opTranslate args (mo_wordEq dflags)+  SameMutableArrayArrayOp -> \args -> opTranslate args (mo_wordEq dflags)+  SameSmallMutableArrayOp -> \args -> opTranslate args (mo_wordEq dflags)+  SameTVarOp              -> \args -> opTranslate args (mo_wordEq dflags)+  EqStablePtrOp           -> \args -> opTranslate args (mo_wordEq dflags)+-- See Note [Comparing stable names]+  EqStableNameOp          -> \args -> opTranslate args (mo_wordEq dflags)++  IntQuotRemOp -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_S_QuotRem  (wordWidth dflags))+    else Right (genericIntQuotRemOp (wordWidth dflags))++  Int8QuotRemOp -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_S_QuotRem W8)+    else Right (genericIntQuotRemOp W8)++  Int16QuotRemOp -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_S_QuotRem W16)+    else Right (genericIntQuotRemOp W16)++  WordQuotRemOp -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_U_QuotRem  (wordWidth dflags))+    else Right (genericWordQuotRemOp (wordWidth dflags))++  WordQuotRem2Op -> \args -> opCallishHandledLater args $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_U_QuotRem2 (wordWidth dflags))+    else Right (genericWordQuotRem2Op dflags)++  Word8QuotRemOp -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_U_QuotRem W8)+    else Right (genericWordQuotRemOp W8)++  Word16QuotRemOp -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_U_QuotRem W16)+    else Right (genericWordQuotRemOp W16)++  WordAdd2Op -> \args -> opCallishHandledLater args $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_Add2       (wordWidth dflags))+    else Right genericWordAdd2Op++  WordAddCOp -> \args -> opCallishHandledLater args $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_AddWordC   (wordWidth dflags))+    else Right genericWordAddCOp++  WordSubCOp -> \args -> opCallishHandledLater args $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_SubWordC   (wordWidth dflags))+    else Right genericWordSubCOp++  IntAddCOp -> \args -> opCallishHandledLater args $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_AddIntC    (wordWidth dflags))+    else Right genericIntAddCOp++  IntSubCOp -> \args -> opCallishHandledLater args $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_SubIntC    (wordWidth dflags))+    else Right genericIntSubCOp++  WordMul2Op -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) || llvm+    then Left (MO_U_Mul2     (wordWidth dflags))+    else Right genericWordMul2Op++  FloatFabsOp -> \args -> opCallishHandledLater args $+    if (ncg && x86ish || ppc) || llvm+    then Left MO_F32_Fabs+    else Right $ genericFabsOp W32++  DoubleFabsOp -> \args -> opCallishHandledLater args $+    if (ncg && x86ish || ppc) || llvm+    then Left MO_F64_Fabs+    else Right $ genericFabsOp W64++  -- tagToEnum# is special: we need to pull the constructor+  -- out of the table, and perform an appropriate return.+  TagToEnumOp -> \[amode] -> PrimopCmmEmit_Raw $ \res_ty -> do+    -- If you're reading this code in the attempt to figure+    -- out why the compiler panic'ed here, it is probably because+    -- you used tagToEnum# in a non-monomorphic setting, e.g.,+    --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#+    -- That won't work.+    let tycon = tyConAppTyCon res_ty+    MASSERT(isEnumerationTyCon tycon)+    dflags <- getDynFlags+    pure [tagToClosure dflags tycon amode]++-- Out of line primops.+-- TODO compiler need not know about these++  UnsafeThawArrayOp -> alwaysExternal+  CasArrayOp -> alwaysExternal+  UnsafeThawSmallArrayOp -> alwaysExternal+  CasSmallArrayOp -> alwaysExternal+  NewPinnedByteArrayOp_Char -> alwaysExternal+  NewAlignedPinnedByteArrayOp_Char -> alwaysExternal+  MutableByteArrayIsPinnedOp -> alwaysExternal+  DoubleDecode_2IntOp -> alwaysExternal+  DoubleDecode_Int64Op -> alwaysExternal+  FloatDecode_IntOp -> alwaysExternal+  ByteArrayIsPinnedOp -> alwaysExternal+  ShrinkMutableByteArrayOp_Char -> alwaysExternal+  ResizeMutableByteArrayOp_Char -> alwaysExternal+  ShrinkSmallMutableArrayOp_Char -> alwaysExternal+  NewArrayArrayOp -> alwaysExternal+  NewMutVarOp -> alwaysExternal+  AtomicModifyMutVar2Op -> alwaysExternal+  AtomicModifyMutVar_Op -> alwaysExternal+  CasMutVarOp -> alwaysExternal+  CatchOp -> alwaysExternal+  RaiseOp -> alwaysExternal+  RaiseIOOp -> alwaysExternal+  MaskAsyncExceptionsOp -> alwaysExternal+  MaskUninterruptibleOp -> alwaysExternal+  UnmaskAsyncExceptionsOp -> alwaysExternal+  MaskStatus -> alwaysExternal+  AtomicallyOp -> alwaysExternal+  RetryOp -> alwaysExternal+  CatchRetryOp -> alwaysExternal+  CatchSTMOp -> alwaysExternal+  NewTVarOp -> alwaysExternal+  ReadTVarOp -> alwaysExternal+  ReadTVarIOOp -> alwaysExternal+  WriteTVarOp -> alwaysExternal+  NewMVarOp -> alwaysExternal+  TakeMVarOp -> alwaysExternal+  TryTakeMVarOp -> alwaysExternal+  PutMVarOp -> alwaysExternal+  TryPutMVarOp -> alwaysExternal+  ReadMVarOp -> alwaysExternal+  TryReadMVarOp -> alwaysExternal+  IsEmptyMVarOp -> alwaysExternal+  DelayOp -> alwaysExternal+  WaitReadOp -> alwaysExternal+  WaitWriteOp -> alwaysExternal+  ForkOp -> alwaysExternal+  ForkOnOp -> alwaysExternal+  KillThreadOp -> alwaysExternal+  YieldOp -> alwaysExternal+  LabelThreadOp -> alwaysExternal+  IsCurrentThreadBoundOp -> alwaysExternal+  NoDuplicateOp -> alwaysExternal+  ThreadStatusOp -> alwaysExternal+  MkWeakOp -> alwaysExternal+  MkWeakNoFinalizerOp -> alwaysExternal+  AddCFinalizerToWeakOp -> alwaysExternal+  DeRefWeakOp -> alwaysExternal+  FinalizeWeakOp -> alwaysExternal+  MakeStablePtrOp -> alwaysExternal+  DeRefStablePtrOp -> alwaysExternal+  MakeStableNameOp -> alwaysExternal+  CompactNewOp -> alwaysExternal+  CompactResizeOp -> alwaysExternal+  CompactContainsOp -> alwaysExternal+  CompactContainsAnyOp -> alwaysExternal+  CompactGetFirstBlockOp -> alwaysExternal+  CompactGetNextBlockOp -> alwaysExternal+  CompactAllocateBlockOp -> alwaysExternal+  CompactFixupPointersOp -> alwaysExternal+  CompactAdd -> alwaysExternal+  CompactAddWithSharing -> alwaysExternal+  CompactSize -> alwaysExternal+  SeqOp -> alwaysExternal+  GetSparkOp -> alwaysExternal+  NumSparks -> alwaysExternal+  DataToTagOp -> alwaysExternal+  MkApUpd0_Op -> alwaysExternal+  NewBCOOp -> alwaysExternal+  UnpackClosureOp -> alwaysExternal+  ClosureSizeOp -> alwaysExternal+  GetApStackValOp -> alwaysExternal+  ClearCCSOp -> alwaysExternal+  TraceEventOp -> alwaysExternal+  TraceEventBinaryOp -> alwaysExternal+  TraceMarkerOp -> alwaysExternal+  SetThreadAllocationCounter -> alwaysExternal++ where+  alwaysExternal = \_ -> PrimopCmmEmit_External+  -- Note [QuotRem optimization]+  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+  --+  -- `quot` and `rem` with constant divisor can be implemented with fast bit-ops+  -- (shift, .&.).+  --+  -- Currently we only support optimization (performed in CmmOpt) when the+  -- constant is a power of 2. #9041 tracks the implementation of the general+  -- optimization.+  --+  -- `quotRem` can be optimized in the same way. However as it returns two values,+  -- it is implemented as a "callish" primop which is harder to match and+  -- to transform later on. For simplicity, the current implementation detects cases+  -- that can be optimized (see `quotRemCanBeOptimized`) and converts STG quotRem+  -- primop into two CMM quot and rem primops.+  quotRemCanBeOptimized = \case+    [_, CmmLit (CmmInt n _) ] -> isJust (exactLog2 n)+    _                         -> False++  ncg = case hscTarget dflags of+           HscAsm -> True+           _      -> False+  llvm = case hscTarget dflags of+           HscLlvm -> True+           _       -> False+  x86ish = case platformArch (targetPlatform dflags) of+             ArchX86    -> True+             ArchX86_64 -> True+             _          -> False+  ppc = case platformArch (targetPlatform dflags) of+          ArchPPC      -> True+          ArchPPC_64 _ -> True+          _            -> False++data PrimopCmmEmit+  = PrimopCmmEmit_External+  | PrimopCmmEmit_IntoRegs ([LocalReg] -- where to put the results+                           -> FCode ())+  -- | Manual escape hatch, this is just for the '@TagToEnum@'+  -- primop for now. It would be nice to remove this special case but that is+  -- future work.+  | PrimopCmmEmit_Raw (Type -- the return type, some primops are specialized to it+                       -> FCode [CmmExpr]) -- just for TagToEnum for now++opNop :: [CmmExpr] -> PrimopCmmEmit+opNop args = PrimopCmmEmit_IntoRegs $ \[res] -> emitAssign (CmmLocal res) arg+  where [arg] = args++opNarrow+  :: DynFlags+  -> [CmmExpr]+  -> (Width -> Width -> MachOp, Width)+  -> PrimopCmmEmit+opNarrow dflags args (mop, rep) = PrimopCmmEmit_IntoRegs $ \[res] -> emitAssign (CmmLocal res) $+  CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]]+  where [arg] = args++-- | These primops are implemented by CallishMachOps, because they sometimes+-- turn into foreign calls depending on the backend.+opCallish :: [CmmExpr] -> CallishMachOp -> PrimopCmmEmit+opCallish args prim = PrimopCmmEmit_IntoRegs $ \[res] -> emitPrimCall [res] prim args++opTranslate :: [CmmExpr] -> MachOp -> PrimopCmmEmit+opTranslate args mop = PrimopCmmEmit_IntoRegs $ \[res] -> do+  let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args)+  emit stmt++-- | Basically a "manual" case, rather than one of the common repetitive forms+-- above. The results are a parameter to the returned function so we know the+-- choice of variant never depends on them.+opCallishHandledLater+  :: [CmmExpr]+  -> Either CallishMachOp GenericOp+  -> PrimopCmmEmit+opCallishHandledLater args callOrNot = PrimopCmmEmit_IntoRegs $ \res0 -> case callOrNot of+  Left op   -> emit $ mkUnsafeCall (PrimTarget op) res0 args+  Right gen -> gen res0 args++opAllDone+  :: ([LocalReg] -- where to put the results+      -> FCode ())+  -> PrimopCmmEmit+opAllDone f = PrimopCmmEmit_IntoRegs $ f++type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()++genericIntQuotRemOp :: Width -> GenericOp+genericIntQuotRemOp width [res_q, res_r] [arg_x, arg_y]+   = emit $ mkAssign (CmmLocal res_q)+              (CmmMachOp (MO_S_Quot width) [arg_x, arg_y]) <*>+            mkAssign (CmmLocal res_r)+              (CmmMachOp (MO_S_Rem  width) [arg_x, arg_y])+genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp"++genericWordQuotRemOp :: Width -> GenericOp+genericWordQuotRemOp width [res_q, res_r] [arg_x, arg_y]+    = emit $ mkAssign (CmmLocal res_q)+               (CmmMachOp (MO_U_Quot width) [arg_x, arg_y]) <*>+             mkAssign (CmmLocal res_r)+               (CmmMachOp (MO_U_Rem  width) [arg_x, arg_y])+genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp"++genericWordQuotRem2Op :: DynFlags -> GenericOp+genericWordQuotRem2Op dflags [res_q, res_r] [arg_x_high, arg_x_low, arg_y]+    = emit =<< f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low+    where    ty = cmmExprType dflags arg_x_high+             shl   x i = CmmMachOp (MO_Shl   (wordWidth dflags)) [x, i]+             shr   x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i]+             or    x y = CmmMachOp (MO_Or    (wordWidth dflags)) [x, y]+             ge    x y = CmmMachOp (MO_U_Ge  (wordWidth dflags)) [x, y]+             ne    x y = CmmMachOp (MO_Ne    (wordWidth dflags)) [x, y]+             minus x y = CmmMachOp (MO_Sub   (wordWidth dflags)) [x, y]+             times x y = CmmMachOp (MO_Mul   (wordWidth dflags)) [x, y]+             zero   = lit 0+             one    = lit 1+             negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1)+             lit i = CmmLit (CmmInt i (wordWidth dflags))++             f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph+             f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*>+                                      mkAssign (CmmLocal res_r) high)+             f i acc high low =+                 do roverflowedBit <- newTemp ty+                    rhigh'         <- newTemp ty+                    rhigh''        <- newTemp ty+                    rlow'          <- newTemp ty+                    risge          <- newTemp ty+                    racc'          <- newTemp ty+                    let high'         = CmmReg (CmmLocal rhigh')+                        isge          = CmmReg (CmmLocal risge)+                        overflowedBit = CmmReg (CmmLocal roverflowedBit)+                    let this = catAGraphs+                               [mkAssign (CmmLocal roverflowedBit)+                                          (shr high negone),+                                mkAssign (CmmLocal rhigh')+                                          (or (shl high one) (shr low negone)),+                                mkAssign (CmmLocal rlow')+                                          (shl low one),+                                mkAssign (CmmLocal risge)+                                          (or (overflowedBit `ne` zero)+                                              (high' `ge` arg_y)),+                                mkAssign (CmmLocal rhigh'')+                                          (high' `minus` (arg_y `times` isge)),+                                mkAssign (CmmLocal racc')+                                          (or (shl acc one) isge)]+                    rest <- f (i - 1) (CmmReg (CmmLocal racc'))+                                      (CmmReg (CmmLocal rhigh''))+                                      (CmmReg (CmmLocal rlow'))+                    return (this <*> rest)+genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op"++genericWordAdd2Op :: GenericOp+genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]+  = do dflags <- getDynFlags+       r1 <- newTemp (cmmExprType dflags arg_x)+       r2 <- newTemp (cmmExprType dflags arg_x)+       let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]+           toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]+           bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]+           add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]+           or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]+           hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))+                                (wordWidth dflags))+           hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))+       emit $ catAGraphs+          [mkAssign (CmmLocal r1)+               (add (bottomHalf arg_x) (bottomHalf arg_y)),+           mkAssign (CmmLocal r2)+               (add (topHalf (CmmReg (CmmLocal r1)))+                    (add (topHalf arg_x) (topHalf arg_y))),+           mkAssign (CmmLocal res_h)+               (topHalf (CmmReg (CmmLocal r2))),+           mkAssign (CmmLocal res_l)+               (or (toTopHalf (CmmReg (CmmLocal r2)))+                   (bottomHalf (CmmReg (CmmLocal r1))))]+genericWordAdd2Op _ _ = panic "genericWordAdd2Op"++-- | Implements branchless recovery of the carry flag @c@ by checking the+-- leftmost bits of both inputs @a@ and @b@ and result @r = a + b@:+--+-- @+--    c = a&b | (a|b)&~r+-- @+--+-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/+genericWordAddCOp :: GenericOp+genericWordAddCOp [res_r, res_c] [aa, bb]+ = do dflags <- getDynFlags+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr dflags) [+            CmmMachOp (mo_wordOr dflags) [+              CmmMachOp (mo_wordAnd dflags) [aa,bb],+              CmmMachOp (mo_wordAnd dflags) [+                CmmMachOp (mo_wordOr dflags) [aa,bb],+                CmmMachOp (mo_wordNot dflags) [CmmReg (CmmLocal res_r)]+              ]+            ],+            mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)+          ]+        ]+genericWordAddCOp _ _ = panic "genericWordAddCOp"++-- | Implements branchless recovery of the carry flag @c@ by checking the+-- leftmost bits of both inputs @a@ and @b@ and result @r = a - b@:+--+-- @+--    c = ~a&b | (~a|b)&r+-- @+--+-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/+genericWordSubCOp :: GenericOp+genericWordSubCOp [res_r, res_c] [aa, bb]+ = do dflags <- getDynFlags+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr dflags) [+            CmmMachOp (mo_wordOr dflags) [+              CmmMachOp (mo_wordAnd dflags) [+                CmmMachOp (mo_wordNot dflags) [aa],+                bb+              ],+              CmmMachOp (mo_wordAnd dflags) [+                CmmMachOp (mo_wordOr dflags) [+                  CmmMachOp (mo_wordNot dflags) [aa],+                  bb+                ],+                CmmReg (CmmLocal res_r)+              ]+            ],+            mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)+          ]+        ]+genericWordSubCOp _ _ = panic "genericWordSubCOp"++genericIntAddCOp :: GenericOp+genericIntAddCOp [res_r, res_c] [aa, bb]+{-+   With some bit-twiddling, we can define int{Add,Sub}Czh portably in+   C, and without needing any comparisons.  This may not be the+   fastest way to do it - if you have better code, please send it! --SDM++   Return : r = a + b,  c = 0 if no overflow, 1 on overflow.++   We currently don't make use of the r value if c is != 0 (i.e.+   overflow), we just convert to big integers and try again.  This+   could be improved by making r and c the correct values for+   plugging into a new J#.++   { r = ((I_)(a)) + ((I_)(b));                                 \+     c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \+         >> (BITS_IN (I_) - 1);                                 \+   }+   Wading through the mass of bracketry, it seems to reduce to:+   c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)++-}+ = do dflags <- getDynFlags+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr dflags) [+                CmmMachOp (mo_wordAnd dflags) [+                    CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]],+                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]+                ],+                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)+          ]+        ]+genericIntAddCOp _ _ = panic "genericIntAddCOp"++genericIntSubCOp :: GenericOp+genericIntSubCOp [res_r, res_c] [aa, bb]+{- Similarly:+   #define subIntCzh(r,c,a,b)                                   \+   { r = ((I_)(a)) - ((I_)(b));                                 \+     c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \+         >> (BITS_IN (I_) - 1);                                 \+   }++   c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)+-}+ = do dflags <- getDynFlags+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr dflags) [+                CmmMachOp (mo_wordAnd dflags) [+                    CmmMachOp (mo_wordXor dflags) [aa,bb],+                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]+                ],+                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)+          ]+        ]+genericIntSubCOp _ _ = panic "genericIntSubCOp"++genericWordMul2Op :: GenericOp+genericWordMul2Op [res_h, res_l] [arg_x, arg_y]+ = do dflags <- getDynFlags+      let t = cmmExprType dflags arg_x+      xlyl <- liftM CmmLocal $ newTemp t+      xlyh <- liftM CmmLocal $ newTemp t+      xhyl <- liftM CmmLocal $ newTemp t+      r    <- liftM CmmLocal $ newTemp t+      -- This generic implementation is very simple and slow. We might+      -- well be able to do better, but for now this at least works.+      let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]+          toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]+          bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]+          add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]+          sum = foldl1 add+          mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y]+          or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]+          hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))+                               (wordWidth dflags))+          hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))+      emit $ catAGraphs+             [mkAssign xlyl+                  (mul (bottomHalf arg_x) (bottomHalf arg_y)),+              mkAssign xlyh+                  (mul (bottomHalf arg_x) (topHalf arg_y)),+              mkAssign xhyl+                  (mul (topHalf arg_x) (bottomHalf arg_y)),+              mkAssign r+                  (sum [topHalf    (CmmReg xlyl),+                        bottomHalf (CmmReg xhyl),+                        bottomHalf (CmmReg xlyh)]),+              mkAssign (CmmLocal res_l)+                  (or (bottomHalf (CmmReg xlyl))+                      (toTopHalf (CmmReg r))),+              mkAssign (CmmLocal res_h)+                  (sum [mul (topHalf arg_x) (topHalf arg_y),+                        topHalf (CmmReg xhyl),+                        topHalf (CmmReg xlyh),+                        topHalf (CmmReg r)])]+genericWordMul2Op _ _ = panic "genericWordMul2Op"++-- This replicates what we had in libraries/base/GHC/Float.hs:+--+--    abs x    | x == 0    = 0 -- handles (-0.0)+--             | x >  0    = x+--             | otherwise = negateFloat x+genericFabsOp :: Width -> GenericOp+genericFabsOp w [res_r] [aa]+ = do dflags <- getDynFlags+      let zero   = CmmLit (CmmFloat 0 w)++          eq x y = CmmMachOp (MO_F_Eq w) [x, y]+          gt x y = CmmMachOp (MO_F_Gt w) [x, y]++          neg x  = CmmMachOp (MO_F_Neg w) [x]++          g1 = catAGraphs [mkAssign (CmmLocal res_r) zero]+          g2 = catAGraphs [mkAssign (CmmLocal res_r) aa]++      res_t <- CmmLocal <$> newTemp (cmmExprType dflags aa)+      let g3 = catAGraphs [mkAssign res_t aa,+                           mkAssign (CmmLocal res_r) (neg (CmmReg res_t))]++      g4 <- mkCmmIfThenElse (gt aa zero) g2 g3++      emit =<< mkCmmIfThenElse (eq aa zero) g1 g4++genericFabsOp _ _ _ = panic "genericFabsOp"++-- Note [Comparing stable names]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- A StableName# is actually a pointer to a stable name object (SNO)+-- containing an index into the stable name table (SNT). We+-- used to compare StableName#s by following the pointers to the+-- SNOs and checking whether they held the same SNT indices. However,+-- this is not necessary: there is a one-to-one correspondence+-- between SNOs and entries in the SNT, so simple pointer equality+-- does the trick.++------------------------------------------------------------------------------+-- Helpers for translating various minor variants of array indexing.++doIndexOffAddrOp :: Maybe MachOp+                 -> CmmType+                 -> [LocalReg]+                 -> [CmmExpr]+                 -> FCode ()+doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]+   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr rep idx+doIndexOffAddrOp _ _ _ _+   = panic "GHC.StgToCmm.Prim: doIndexOffAddrOp"++doIndexOffAddrOpAs :: Maybe MachOp+                   -> CmmType+                   -> CmmType+                   -> [LocalReg]+                   -> [CmmExpr]+                   -> FCode ()+doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]+   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx_rep idx+doIndexOffAddrOpAs _ _ _ _ _+   = panic "GHC.StgToCmm.Prim: doIndexOffAddrOpAs"++doIndexByteArrayOp :: Maybe MachOp+                   -> CmmType+                   -> [LocalReg]+                   -> [CmmExpr]+                   -> FCode ()+doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]+   = do dflags <- getDynFlags+        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr rep idx+doIndexByteArrayOp _ _ _ _+   = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp"++doIndexByteArrayOpAs :: Maybe MachOp+                    -> CmmType+                    -> CmmType+                    -> [LocalReg]+                    -> [CmmExpr]+                    -> FCode ()+doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]+   = do dflags <- getDynFlags+        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx_rep idx+doIndexByteArrayOpAs _ _ _ _ _+   = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs"++doReadPtrArrayOp :: LocalReg+                 -> CmmExpr+                 -> CmmExpr+                 -> FCode ()+doReadPtrArrayOp res addr idx+   = do dflags <- getDynFlags+        mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr (gcWord dflags) idx++doWriteOffAddrOp :: Maybe MachOp+                 -> CmmType+                 -> [LocalReg]+                 -> [CmmExpr]+                 -> FCode ()+doWriteOffAddrOp maybe_pre_write_cast idx_ty [] [addr,idx,val]+   = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val+doWriteOffAddrOp _ _ _ _+   = panic "GHC.StgToCmm.Prim: doWriteOffAddrOp"++doWriteByteArrayOp :: Maybe MachOp+                   -> CmmType+                   -> [LocalReg]+                   -> [CmmExpr]+                   -> FCode ()+doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val]+   = do dflags <- getDynFlags+        mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx_ty idx val+doWriteByteArrayOp _ _ _ _+   = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp"++doWritePtrArrayOp :: CmmExpr+                  -> CmmExpr+                  -> CmmExpr+                  -> FCode ()+doWritePtrArrayOp addr idx val+  = do dflags <- getDynFlags+       let ty = cmmExprType dflags val+           hdr_size = arrPtrsHdrSize dflags+       -- Update remembered set for non-moving collector+       whenUpdRemSetEnabled dflags+           $ emitUpdRemSetPush (cmmLoadIndexOffExpr dflags hdr_size ty addr ty idx)+       -- This write barrier is to ensure that the heap writes to the object+       -- referred to by val have happened before we write val into the array.+       -- See #12469 for details.+       emitPrimCall [] MO_WriteBarrier []+       mkBasicIndexedWrite hdr_size Nothing addr ty idx val+       emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))+       -- the write barrier.  We must write a byte into the mark table:+       -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]+       emit $ mkStore (+         cmmOffsetExpr dflags+          (cmmOffsetExprW dflags (cmmOffsetB dflags addr hdr_size)+                         (loadArrPtrsSize dflags addr))+          (CmmMachOp (mo_wordUShr dflags) [idx,+                                           mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)])+         ) (CmmLit (CmmInt 1 W8))++loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr+loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags)+ where off = fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags++mkBasicIndexedRead :: ByteOff      -- Initial offset in bytes+                   -> Maybe MachOp -- Optional result cast+                   -> CmmType      -- Type of element we are accessing+                   -> LocalReg     -- Destination+                   -> CmmExpr      -- Base address+                   -> CmmType      -- Type of element by which we are indexing+                   -> CmmExpr      -- Index+                   -> FCode ()+mkBasicIndexedRead off Nothing ty res base idx_ty idx+   = do dflags <- getDynFlags+        emitAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off ty base idx_ty idx)+mkBasicIndexedRead off (Just cast) ty res base idx_ty idx+   = do dflags <- getDynFlags+        emitAssign (CmmLocal res) (CmmMachOp cast [+                                   cmmLoadIndexOffExpr dflags off ty base idx_ty idx])++mkBasicIndexedWrite :: ByteOff      -- Initial offset in bytes+                    -> Maybe MachOp -- Optional value cast+                    -> CmmExpr      -- Base address+                    -> CmmType      -- Type of element by which we are indexing+                    -> CmmExpr      -- Index+                    -> CmmExpr      -- Value to write+                    -> FCode ()+mkBasicIndexedWrite off Nothing base idx_ty idx val+   = do dflags <- getDynFlags+        emitStore (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) val+mkBasicIndexedWrite off (Just cast) base idx_ty idx val+   = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val])++-- ----------------------------------------------------------------------------+-- Misc utils++cmmIndexOffExpr :: DynFlags+                -> ByteOff  -- Initial offset in bytes+                -> Width    -- Width of element by which we are indexing+                -> CmmExpr  -- Base address+                -> CmmExpr  -- Index+                -> CmmExpr+cmmIndexOffExpr dflags off width base idx+   = cmmIndexExpr dflags width (cmmOffsetB dflags base off) idx++cmmLoadIndexOffExpr :: DynFlags+                    -> ByteOff  -- Initial offset in bytes+                    -> CmmType  -- Type of element we are accessing+                    -> CmmExpr  -- Base address+                    -> CmmType  -- Type of element by which we are indexing+                    -> CmmExpr  -- Index+                    -> CmmExpr+cmmLoadIndexOffExpr dflags off ty base idx_ty idx+   = CmmLoad (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) ty++setInfo :: CmmExpr -> CmmExpr -> CmmAGraph+setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr++------------------------------------------------------------------------------+-- Helpers for translating vector primops.++vecVmmType :: PrimOpVecCat -> Length -> Width -> CmmType+vecVmmType pocat n w = vec n (vecCmmCat pocat w)++vecCmmCat :: PrimOpVecCat -> Width -> CmmType+vecCmmCat IntVec   = cmmBits+vecCmmCat WordVec  = cmmBits+vecCmmCat FloatVec = cmmFloat++vecElemInjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp+vecElemInjectCast _      FloatVec _   =  Nothing+vecElemInjectCast dflags IntVec   W8  =  Just (mo_WordTo8  dflags)+vecElemInjectCast dflags IntVec   W16 =  Just (mo_WordTo16 dflags)+vecElemInjectCast dflags IntVec   W32 =  Just (mo_WordTo32 dflags)+vecElemInjectCast _      IntVec   W64 =  Nothing+vecElemInjectCast dflags WordVec  W8  =  Just (mo_WordTo8  dflags)+vecElemInjectCast dflags WordVec  W16 =  Just (mo_WordTo16 dflags)+vecElemInjectCast dflags WordVec  W32 =  Just (mo_WordTo32 dflags)+vecElemInjectCast _      WordVec  W64 =  Nothing+vecElemInjectCast _      _        _   =  Nothing++vecElemProjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp+vecElemProjectCast _      FloatVec _   =  Nothing+vecElemProjectCast dflags IntVec   W8  =  Just (mo_s_8ToWord  dflags)+vecElemProjectCast dflags IntVec   W16 =  Just (mo_s_16ToWord dflags)+vecElemProjectCast dflags IntVec   W32 =  Just (mo_s_32ToWord dflags)+vecElemProjectCast _      IntVec   W64 =  Nothing+vecElemProjectCast dflags WordVec  W8  =  Just (mo_u_8ToWord  dflags)+vecElemProjectCast dflags WordVec  W16 =  Just (mo_u_16ToWord dflags)+vecElemProjectCast dflags WordVec  W32 =  Just (mo_u_32ToWord dflags)+vecElemProjectCast _      WordVec  W64 =  Nothing+vecElemProjectCast _      _        _   =  Nothing+++-- NOTE [SIMD Design for the future]+-- Check to make sure that we can generate code for the specified vector type+-- given the current set of dynamic flags.+-- Currently these checks are specific to x86 and x86_64 architecture.+-- This should be fixed!+-- In particular,+-- 1) Add better support for other architectures! (this may require a redesign)+-- 2) Decouple design choices from LLVM's pseudo SIMD model!+--   The high level LLVM naive rep makes per CPU family SIMD generation is own+--   optimization problem, and hides important differences in eg ARM vs x86_64 simd+-- 3) Depending on the architecture, the SIMD registers may also support general+--    computations on Float/Double/Word/Int scalars, but currently on+--    for example x86_64, we always put Word/Int (or sized) in GPR+--    (general purpose) registers. Would relaxing that allow for+--    useful optimization opportunities?+--      Phrased differently, it is worth experimenting with supporting+--    different register mapping strategies than we currently have, especially if+--    someday we want SIMD to be a first class denizen in GHC along with scalar+--    values!+--      The current design with respect to register mapping of scalars could+--    very well be the best,but exploring the  design space and doing careful+--    measurments is the only only way to validate that.+--      In some next generation CPU ISAs, notably RISC V, the SIMD extension+--    includes  support for a sort of run time CPU dependent vectorization parameter,+--    where a loop may act upon a single scalar each iteration OR some 2,4,8 ...+--    element chunk! Time will tell if that direction sees wide adoption,+--    but it is from that context that unifying our handling of simd and scalars+--    may benefit. It is not likely to benefit current architectures, though+--    it may very well be a design perspective that helps guide improving the NCG.+++checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode ()+checkVecCompatibility dflags vcat l w = do+    when (hscTarget dflags /= HscLlvm) $ do+        sorry $ unlines ["SIMD vector instructions require the LLVM back-end."+                         ,"Please use -fllvm."]+    check vecWidth vcat l w+  where+    check :: Width -> PrimOpVecCat -> Length -> Width -> FCode ()+    check W128 FloatVec 4 W32 | not (isSseEnabled dflags) =+        sorry $ "128-bit wide single-precision floating point " +++                "SIMD vector instructions require at least -msse."+    check W128 _ _ _ | not (isSse2Enabled dflags) =+        sorry $ "128-bit wide integer and double precision " +++                "SIMD vector instructions require at least -msse2."+    check W256 FloatVec _ _ | not (isAvxEnabled dflags) =+        sorry $ "256-bit wide floating point " +++                "SIMD vector instructions require at least -mavx."+    check W256 _ _ _ | not (isAvx2Enabled dflags) =+        sorry $ "256-bit wide integer " +++                "SIMD vector instructions require at least -mavx2."+    check W512 _ _ _ | not (isAvx512fEnabled dflags) =+        sorry $ "512-bit wide " +++                "SIMD vector instructions require -mavx512f."+    check _ _ _ _ = return ()++    vecWidth = typeWidth (vecVmmType vcat l w)++------------------------------------------------------------------------------+-- Helpers for translating vector packing and unpacking.++doVecPackOp :: Maybe MachOp  -- Cast from element to vector component+            -> CmmType       -- Type of vector+            -> CmmExpr       -- Initial vector+            -> [CmmExpr]     -- Elements+            -> CmmFormal     -- Destination for result+            -> FCode ()+doVecPackOp maybe_pre_write_cast ty z es res = do+    dst <- newTemp ty+    emitAssign (CmmLocal dst) z+    vecPack dst es 0+  where+    vecPack :: CmmFormal -> [CmmExpr] -> Int -> FCode ()+    vecPack src [] _ =+        emitAssign (CmmLocal res) (CmmReg (CmmLocal src))++    vecPack src (e : es) i = do+        dst <- newTemp ty+        if isFloatType (vecElemType ty)+          then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid)+                                                    [CmmReg (CmmLocal src), cast e, iLit])+          else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid)+                                                    [CmmReg (CmmLocal src), cast e, iLit])+        vecPack dst es (i + 1)+      where+        -- vector indices are always 32-bits+        iLit = CmmLit (CmmInt (toInteger i) W32)++    cast :: CmmExpr -> CmmExpr+    cast val = case maybe_pre_write_cast of+                 Nothing   -> val+                 Just cast -> CmmMachOp cast [val]++    len :: Length+    len = vecLength ty++    wid :: Width+    wid = typeWidth (vecElemType ty)++doVecUnpackOp :: Maybe MachOp  -- Cast from vector component to element result+              -> CmmType       -- Type of vector+              -> CmmExpr       -- Vector+              -> [CmmFormal]   -- Element results+              -> FCode ()+doVecUnpackOp maybe_post_read_cast ty e res =+    vecUnpack res 0+  where+    vecUnpack :: [CmmFormal] -> Int -> FCode ()+    vecUnpack [] _ =+        return ()++    vecUnpack (r : rs) i = do+        if isFloatType (vecElemType ty)+          then emitAssign (CmmLocal r) (cast (CmmMachOp (MO_VF_Extract len wid)+                                             [e, iLit]))+          else emitAssign (CmmLocal r) (cast (CmmMachOp (MO_V_Extract len wid)+                                             [e, iLit]))+        vecUnpack rs (i + 1)+      where+        -- vector indices are always 32-bits+        iLit = CmmLit (CmmInt (toInteger i) W32)++    cast :: CmmExpr -> CmmExpr+    cast val = case maybe_post_read_cast of+                 Nothing   -> val+                 Just cast -> CmmMachOp cast [val]++    len :: Length+    len = vecLength ty++    wid :: Width+    wid = typeWidth (vecElemType ty)++doVecInsertOp :: Maybe MachOp  -- Cast from element to vector component+              -> CmmType       -- Vector type+              -> CmmExpr       -- Source vector+              -> CmmExpr       -- Element+              -> CmmExpr       -- Index at which to insert element+              -> CmmFormal     -- Destination for result+              -> FCode ()+doVecInsertOp maybe_pre_write_cast ty src e idx res = do+    dflags <- getDynFlags+    -- vector indices are always 32-bits+    let idx' :: CmmExpr+        idx' = CmmMachOp (MO_SS_Conv (wordWidth dflags) W32) [idx]+    if isFloatType (vecElemType ty)+      then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, cast e, idx'])+      else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, cast e, idx'])+  where+    cast :: CmmExpr -> CmmExpr+    cast val = case maybe_pre_write_cast of+                 Nothing   -> val+                 Just cast -> CmmMachOp cast [val]++    len :: Length+    len = vecLength ty++    wid :: Width+    wid = typeWidth (vecElemType ty)++------------------------------------------------------------------------------+-- Helpers for translating prefetching.+++-- | Translate byte array prefetch operations into proper primcalls.+doPrefetchByteArrayOp :: Int+                      -> [CmmExpr]+                      -> FCode ()+doPrefetchByteArrayOp locality  [addr,idx]+   = do dflags <- getDynFlags+        mkBasicPrefetch locality (arrWordsHdrSize dflags)  addr idx+doPrefetchByteArrayOp _ _+   = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp"++-- | Translate mutable byte array prefetch operations into proper primcalls.+doPrefetchMutableByteArrayOp :: Int+                      -> [CmmExpr]+                      -> FCode ()+doPrefetchMutableByteArrayOp locality  [addr,idx]+   = do dflags <- getDynFlags+        mkBasicPrefetch locality (arrWordsHdrSize dflags)  addr idx+doPrefetchMutableByteArrayOp _ _+   = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp"++-- | Translate address prefetch operations into proper primcalls.+doPrefetchAddrOp ::Int+                 -> [CmmExpr]+                 -> FCode ()+doPrefetchAddrOp locality   [addr,idx]+   = mkBasicPrefetch locality 0  addr idx+doPrefetchAddrOp _ _+   = panic "GHC.StgToCmm.Prim: doPrefetchAddrOp"++-- | Translate value prefetch operations into proper primcalls.+doPrefetchValueOp :: Int+                 -> [CmmExpr]+                 -> FCode ()+doPrefetchValueOp  locality   [addr]+  =  do dflags <- getDynFlags+        mkBasicPrefetch locality 0 addr  (CmmLit (CmmInt 0 (wordWidth dflags)))+doPrefetchValueOp _ _+  = panic "GHC.StgToCmm.Prim: doPrefetchValueOp"++-- | helper to generate prefetch primcalls+mkBasicPrefetch :: Int          -- Locality level 0-3+                -> ByteOff      -- Initial offset in bytes+                -> CmmExpr      -- Base address+                -> CmmExpr      -- Index+                -> FCode ()+mkBasicPrefetch locality off base idx+   = do dflags <- getDynFlags+        emitPrimCall [] (MO_Prefetch_Data locality) [cmmIndexExpr dflags W8 (cmmOffsetB dflags base off) idx]+        return ()++-- ----------------------------------------------------------------------------+-- Allocating byte arrays++-- | Takes a register to return the newly allocated array in and the+-- size of the new array in bytes. Allocates a new+-- 'MutableByteArray#'.+doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode ()+doNewByteArrayOp res_r n = do+    dflags <- getDynFlags++    let info_ptr = mkLblExpr mkArrWords_infoLabel+        rep = arrWordsRep dflags n++    tickyAllocPrim (mkIntExpr dflags (arrWordsHdrSize dflags))+        (mkIntExpr dflags (nonHdrSize dflags rep))+        (zeroExpr dflags)++    let hdr_size = fixedHdrSize dflags++    base <- allocHeapClosure rep info_ptr cccsExpr+                     [ (mkIntExpr dflags n,+                        hdr_size + oFFSET_StgArrBytes_bytes dflags)+                     ]++    emit $ mkAssign (CmmLocal res_r) base++-- ----------------------------------------------------------------------------+-- Comparing byte arrays++doCompareByteArraysOp :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                     -> FCode ()+doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do+    dflags <- getDynFlags+    ba1_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba1 (arrWordsHdrSize dflags)) ba1_off+    ba2_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba2 (arrWordsHdrSize dflags)) ba2_off++    -- short-cut in case of equal pointers avoiding a costly+    -- subroutine call to the memcmp(3) routine; the Cmm logic below+    -- results in assembly code being generated for+    --+    --   cmpPrefix10 :: ByteArray# -> ByteArray# -> Int#+    --   cmpPrefix10 ba1 ba2 = compareByteArrays# ba1 0# ba2 0# 10#+    --+    -- that looks like+    --+    --          leaq 16(%r14),%rax+    --          leaq 16(%rsi),%rbx+    --          xorl %ecx,%ecx+    --          cmpq %rbx,%rax+    --          je l_ptr_eq+    --+    --          ; NB: the common case (unequal pointers) falls-through+    --          ; the conditional jump, and therefore matches the+    --          ; usual static branch prediction convention of modern cpus+    --+    --          subq $8,%rsp+    --          movq %rbx,%rsi+    --          movq %rax,%rdi+    --          movl $10,%edx+    --          xorl %eax,%eax+    --          call memcmp+    --          addq $8,%rsp+    --          movslq %eax,%rax+    --          movq %rax,%rcx+    --  l_ptr_eq:+    --          movq %rcx,%rbx+    --          jmp *(%rbp)++    l_ptr_eq <- newBlockId+    l_ptr_ne <- newBlockId++    emit (mkAssign (CmmLocal res) (zeroExpr dflags))+    emit (mkCbranch (cmmEqWord dflags ba1_p ba2_p)+                    l_ptr_eq l_ptr_ne (Just False))++    emitLabel l_ptr_ne+    emitMemcmpCall res ba1_p ba2_p n 1++    emitLabel l_ptr_eq++-- ----------------------------------------------------------------------------+-- Copying byte arrays++-- | Takes a source 'ByteArray#', an offset in the source array, a+-- destination 'MutableByteArray#', an offset into the destination+-- array, and the number of bytes to copy.  Copies the given number of+-- bytes from the source array to the destination array.+doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                  -> FCode ()+doCopyByteArrayOp = emitCopyByteArray copy+  where+    -- Copy data (we assume the arrays aren't overlapping since+    -- they're of different types)+    copy _src _dst dst_p src_p bytes align =+        emitMemcpyCall dst_p src_p bytes align++-- | Takes a source 'MutableByteArray#', an offset in the source+-- array, a destination 'MutableByteArray#', an offset into the+-- destination array, and the number of bytes to copy.  Copies the+-- given number of bytes from the source array to the destination+-- array.+doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                         -> FCode ()+doCopyMutableByteArrayOp = emitCopyByteArray copy+  where+    -- The only time the memory might overlap is when the two arrays+    -- we were provided are the same array!+    -- TODO: Optimize branch for common case of no aliasing.+    copy src dst dst_p src_p bytes align = do+        dflags <- getDynFlags+        (moveCall, cpyCall) <- forkAltPair+            (getCode $ emitMemmoveCall dst_p src_p bytes align)+            (getCode $ emitMemcpyCall  dst_p src_p bytes align)+        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall++emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                      -> Alignment -> FCode ())+                  -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                  -> FCode ()+emitCopyByteArray copy src src_off dst dst_off n = do+    dflags <- getDynFlags+    let byteArrayAlignment = wordAlignment dflags+        srcOffAlignment = cmmExprAlignment src_off+        dstOffAlignment = cmmExprAlignment dst_off+        align = minimum [byteArrayAlignment, srcOffAlignment, dstOffAlignment]+    dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off+    src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off+    copy src dst dst_p src_p n align++-- | Takes a source 'ByteArray#', an offset in the source array, a+-- destination 'Addr#', and the number of bytes to copy.  Copies the given+-- number of bytes from the source array to the destination memory region.+doCopyByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()+doCopyByteArrayToAddrOp src src_off dst_p bytes = do+    -- Use memcpy (we are allowed to assume the arrays aren't overlapping)+    dflags <- getDynFlags+    src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off+    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)++-- | Takes a source 'MutableByteArray#', an offset in the source array, a+-- destination 'Addr#', and the number of bytes to copy.  Copies the given+-- number of bytes from the source array to the destination memory region.+doCopyMutableByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                               -> FCode ()+doCopyMutableByteArrayToAddrOp = doCopyByteArrayToAddrOp++-- | Takes a source 'Addr#', a destination 'MutableByteArray#', an offset into+-- the destination array, and the number of bytes to copy.  Copies the given+-- number of bytes from the source memory region to the destination array.+doCopyAddrToByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()+doCopyAddrToByteArrayOp src_p dst dst_off bytes = do+    -- Use memcpy (we are allowed to assume the arrays aren't overlapping)+    dflags <- getDynFlags+    dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off+    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)+++-- ----------------------------------------------------------------------------+-- Setting byte arrays++-- | Takes a 'MutableByteArray#', an offset into the array, a length,+-- and a byte, and sets each of the selected bytes in the array to the+-- character.+doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                 -> FCode ()+doSetByteArrayOp ba off len c = do+    dflags <- getDynFlags++    let byteArrayAlignment = wordAlignment dflags -- known since BA is allocated on heap+        offsetAlignment = cmmExprAlignment off+        align = min byteArrayAlignment offsetAlignment++    p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off+    emitMemsetCall p c len align++-- ----------------------------------------------------------------------------+-- Allocating arrays++-- | Allocate a new array.+doNewArrayOp :: CmmFormal             -- ^ return register+             -> SMRep                 -- ^ representation of the array+             -> CLabel                -- ^ info pointer+             -> [(CmmExpr, ByteOff)]  -- ^ header payload+             -> WordOff               -- ^ array size+             -> CmmExpr               -- ^ initial element+             -> FCode ()+doNewArrayOp res_r rep info payload n init = do+    dflags <- getDynFlags++    let info_ptr = mkLblExpr info++    tickyAllocPrim (mkIntExpr dflags (hdrSize dflags rep))+        (mkIntExpr dflags (nonHdrSize dflags rep))+        (zeroExpr dflags)++    base <- allocHeapClosure rep info_ptr cccsExpr payload++    arr <- CmmLocal `fmap` newTemp (bWord dflags)+    emit $ mkAssign arr base++    -- Initialise all elements of the array+    let mkOff off = cmmOffsetW dflags (CmmReg arr) (hdrSizeW dflags rep + off)+        initialization = [ mkStore (mkOff off) init | off <- [0.. n - 1] ]+    emit (catAGraphs initialization)++    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)++-- ----------------------------------------------------------------------------+-- Copying pointer arrays++-- EZY: This code has an unusually high amount of assignTemp calls, seen+-- nowhere else in the code generator.  This is mostly because these+-- "primitive" ops result in a surprisingly large amount of code.  It+-- will likely be worthwhile to optimize what is emitted here, so that+-- our optimization passes don't waste time repeatedly optimizing the+-- same bits of code.++-- More closely imitates 'assignTemp' from the old code generator, which+-- returns a CmmExpr rather than a LocalReg.+assignTempE :: CmmExpr -> FCode CmmExpr+assignTempE e = do+    t <- assignTemp e+    return (CmmReg (CmmLocal t))++-- | Takes a source 'Array#', an offset in the source array, a+-- destination 'MutableArray#', an offset into the destination array,+-- and the number of elements to copy.  Copies the given number of+-- elements from the source array to the destination array.+doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff+              -> FCode ()+doCopyArrayOp = emitCopyArray copy+  where+    -- Copy data (we assume the arrays aren't overlapping since+    -- they're of different types)+    copy _src _dst dst_p src_p bytes =+        do dflags <- getDynFlags+           emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)+               (wordAlignment dflags)+++-- | Takes a source 'MutableArray#', an offset in the source array, a+-- destination 'MutableArray#', an offset into the destination array,+-- and the number of elements to copy.  Copies the given number of+-- elements from the source array to the destination array.+doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff+                     -> FCode ()+doCopyMutableArrayOp = emitCopyArray copy+  where+    -- The only time the memory might overlap is when the two arrays+    -- we were provided are the same array!+    -- TODO: Optimize branch for common case of no aliasing.+    copy src dst dst_p src_p bytes = do+        dflags <- getDynFlags+        (moveCall, cpyCall) <- forkAltPair+            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)+             (wordAlignment dflags))+            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)+             (wordAlignment dflags))+        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall++emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff+                  -> FCode ())  -- ^ copy function+              -> CmmExpr        -- ^ source array+              -> CmmExpr        -- ^ offset in source array+              -> CmmExpr        -- ^ destination array+              -> CmmExpr        -- ^ offset in destination array+              -> WordOff        -- ^ number of elements to copy+              -> FCode ()+emitCopyArray copy src0 src_off dst0 dst_off0 n =+    when (n /= 0) $ do+        dflags <- getDynFlags++        -- Passed as arguments (be careful)+        src     <- assignTempE src0+        dst     <- assignTempE dst0+        dst_off <- assignTempE dst_off0++        -- Nonmoving collector write barrier+        emitCopyUpdRemSetPush dflags (arrPtrsHdrSizeW dflags) dst dst_off n++        -- Set the dirty bit in the header.+        emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))++        dst_elems_p <- assignTempE $ cmmOffsetB dflags dst+                       (arrPtrsHdrSize dflags)+        dst_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p dst_off+        src_p <- assignTempE $ cmmOffsetExprW dflags+                 (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off+        let bytes = wordsToBytes dflags n++        copy src dst dst_p src_p bytes++        -- The base address of the destination card table+        dst_cards_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p+                       (loadArrPtrsSize dflags dst)++        emitSetCards dst_off dst_cards_p n++doCopySmallArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff+                   -> FCode ()+doCopySmallArrayOp = emitCopySmallArray copy+  where+    -- Copy data (we assume the arrays aren't overlapping since+    -- they're of different types)+    copy _src _dst dst_p src_p bytes =+        do dflags <- getDynFlags+           emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)+               (wordAlignment dflags)+++doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff+                          -> FCode ()+doCopySmallMutableArrayOp = emitCopySmallArray copy+  where+    -- The only time the memory might overlap is when the two arrays+    -- we were provided are the same array!+    -- TODO: Optimize branch for common case of no aliasing.+    copy src dst dst_p src_p bytes = do+        dflags <- getDynFlags+        (moveCall, cpyCall) <- forkAltPair+            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)+             (wordAlignment dflags))+            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)+             (wordAlignment dflags))+        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall++emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff+                       -> FCode ())  -- ^ copy function+                   -> CmmExpr        -- ^ source array+                   -> CmmExpr        -- ^ offset in source array+                   -> CmmExpr        -- ^ destination array+                   -> CmmExpr        -- ^ offset in destination array+                   -> WordOff        -- ^ number of elements to copy+                   -> FCode ()+emitCopySmallArray copy src0 src_off dst0 dst_off n =+    when (n /= 0) $ do+        dflags <- getDynFlags++        -- Passed as arguments (be careful)+        src     <- assignTempE src0+        dst     <- assignTempE dst0++        -- Nonmoving collector write barrier+        emitCopyUpdRemSetPush dflags (smallArrPtrsHdrSizeW dflags) dst dst_off n++        -- Set the dirty bit in the header.+        emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))++        dst_p <- assignTempE $ cmmOffsetExprW dflags+                 (cmmOffsetB dflags dst (smallArrPtrsHdrSize dflags)) dst_off+        src_p <- assignTempE $ cmmOffsetExprW dflags+                 (cmmOffsetB dflags src (smallArrPtrsHdrSize dflags)) src_off+        let bytes = wordsToBytes dflags n++        copy src dst dst_p src_p bytes++-- | Takes an info table label, a register to return the newly+-- allocated array in, a source array, an offset in the source array,+-- and the number of elements to copy. Allocates a new array and+-- initializes it from the source array.+emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff+               -> FCode ()+emitCloneArray info_p res_r src src_off n = do+    dflags <- getDynFlags++    let info_ptr = mkLblExpr info_p+        rep = arrPtrsRep dflags n++    tickyAllocPrim (mkIntExpr dflags (arrPtrsHdrSize dflags))+        (mkIntExpr dflags (nonHdrSize dflags rep))+        (zeroExpr dflags)++    let hdr_size = fixedHdrSize dflags++    base <- allocHeapClosure rep info_ptr cccsExpr+                     [ (mkIntExpr dflags n,+                        hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags)+                     , (mkIntExpr dflags (nonHdrSizeW rep),+                        hdr_size + oFFSET_StgMutArrPtrs_size dflags)+                     ]++    arr <- CmmLocal `fmap` newTemp (bWord dflags)+    emit $ mkAssign arr base++    dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr)+             (arrPtrsHdrSize dflags)+    src_p <- assignTempE $ cmmOffsetExprW dflags src+             (cmmAddWord dflags+              (mkIntExpr dflags (arrPtrsHdrSizeW dflags)) src_off)++    emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))+        (wordAlignment dflags)++    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)++-- | Takes an info table label, a register to return the newly+-- allocated array in, a source array, an offset in the source array,+-- and the number of elements to copy. Allocates a new array and+-- initializes it from the source array.+emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff+                    -> FCode ()+emitCloneSmallArray info_p res_r src src_off n = do+    dflags <- getDynFlags++    let info_ptr = mkLblExpr info_p+        rep = smallArrPtrsRep n++    tickyAllocPrim (mkIntExpr dflags (smallArrPtrsHdrSize dflags))+        (mkIntExpr dflags (nonHdrSize dflags rep))+        (zeroExpr dflags)++    let hdr_size = fixedHdrSize dflags++    base <- allocHeapClosure rep info_ptr cccsExpr+                     [ (mkIntExpr dflags n,+                        hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags)+                     ]++    arr <- CmmLocal `fmap` newTemp (bWord dflags)+    emit $ mkAssign arr base++    dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr)+             (smallArrPtrsHdrSize dflags)+    src_p <- assignTempE $ cmmOffsetExprW dflags src+             (cmmAddWord dflags+              (mkIntExpr dflags (smallArrPtrsHdrSizeW dflags)) src_off)++    emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))+        (wordAlignment dflags)++    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)++-- | Takes and offset in the destination array, the base address of+-- the card table, and the number of elements affected (*not* the+-- number of cards). The number of elements may not be zero.+-- Marks the relevant cards as dirty.+emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode ()+emitSetCards dst_start dst_cards_start n = do+    dflags <- getDynFlags+    start_card <- assignTempE $ cardCmm dflags dst_start+    let end_card = cardCmm dflags+                   (cmmSubWord dflags+                    (cmmAddWord dflags dst_start (mkIntExpr dflags n))+                    (mkIntExpr dflags 1))+    emitMemsetCall (cmmAddWord dflags dst_cards_start start_card)+        (mkIntExpr dflags 1)+        (cmmAddWord dflags (cmmSubWord dflags end_card start_card) (mkIntExpr dflags 1))+        (mkAlignment 1) -- no alignment (1 byte)++-- Convert an element index to a card index+cardCmm :: DynFlags -> CmmExpr -> CmmExpr+cardCmm dflags i =+    cmmUShrWord dflags i (mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags))++------------------------------------------------------------------------------+-- SmallArray PrimOp implementations++doReadSmallPtrArrayOp :: LocalReg+                      -> CmmExpr+                      -> CmmExpr+                      -> FCode ()+doReadSmallPtrArrayOp res addr idx = do+    dflags <- getDynFlags+    mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr+        (gcWord dflags) idx++doWriteSmallPtrArrayOp :: CmmExpr+                       -> CmmExpr+                       -> CmmExpr+                       -> FCode ()+doWriteSmallPtrArrayOp addr idx val = do+    dflags <- getDynFlags+    let ty = cmmExprType dflags val++    -- Update remembered set for non-moving collector+    tmp <- newTemp ty+    mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing ty tmp addr ty idx+    whenUpdRemSetEnabled dflags $ emitUpdRemSetPush (CmmReg (CmmLocal tmp))++    emitPrimCall [] MO_WriteBarrier [] -- #12469+    mkBasicIndexedWrite (smallArrPtrsHdrSize dflags) Nothing addr ty idx val+    emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))++------------------------------------------------------------------------------+-- Atomic read-modify-write++-- | Emit an atomic modification to a byte array element. The result+-- reg contains that previous value of the element. Implies a full+-- memory barrier.+doAtomicRMW :: LocalReg      -- ^ Result reg+            -> AtomicMachOp  -- ^ Atomic op (e.g. add)+            -> CmmExpr       -- ^ MutableByteArray#+            -> CmmExpr       -- ^ Index+            -> CmmType       -- ^ Type of element by which we are indexing+            -> CmmExpr       -- ^ Op argument (e.g. amount to add)+            -> FCode ()+doAtomicRMW res amop mba idx idx_ty n = do+    dflags <- getDynFlags+    let width = typeWidth idx_ty+        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)+                width mba idx+    emitPrimCall+        [ res ]+        (MO_AtomicRMW width amop)+        [ addr, n ]++-- | Emit an atomic read to a byte array that acts as a memory barrier.+doAtomicReadByteArray+    :: LocalReg  -- ^ Result reg+    -> CmmExpr   -- ^ MutableByteArray#+    -> CmmExpr   -- ^ Index+    -> CmmType   -- ^ Type of element by which we are indexing+    -> FCode ()+doAtomicReadByteArray res mba idx idx_ty = do+    dflags <- getDynFlags+    let width = typeWidth idx_ty+        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)+                width mba idx+    emitPrimCall+        [ res ]+        (MO_AtomicRead width)+        [ addr ]++-- | Emit an atomic write to a byte array that acts as a memory barrier.+doAtomicWriteByteArray+    :: CmmExpr   -- ^ MutableByteArray#+    -> CmmExpr   -- ^ Index+    -> CmmType   -- ^ Type of element by which we are indexing+    -> CmmExpr   -- ^ Value to write+    -> FCode ()+doAtomicWriteByteArray mba idx idx_ty val = do+    dflags <- getDynFlags+    let width = typeWidth idx_ty+        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)+                width mba idx+    emitPrimCall+        [ {- no results -} ]+        (MO_AtomicWrite width)+        [ addr, val ]++doCasByteArray+    :: LocalReg  -- ^ Result reg+    -> CmmExpr   -- ^ MutableByteArray#+    -> CmmExpr   -- ^ Index+    -> CmmType   -- ^ Type of element by which we are indexing+    -> CmmExpr   -- ^ Old value+    -> CmmExpr   -- ^ New value+    -> FCode ()+doCasByteArray res mba idx idx_ty old new = do+    dflags <- getDynFlags+    let width = (typeWidth idx_ty)+        addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)+               width mba idx+    emitPrimCall+        [ res ]+        (MO_Cmpxchg width)+        [ addr, old, new ]++------------------------------------------------------------------------------+-- Helpers for emitting function calls++-- | Emit a call to @memcpy@.+emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()+emitMemcpyCall dst src n align = do+    emitPrimCall+        [ {-no results-} ]+        (MO_Memcpy (alignmentBytes align))+        [ dst, src, n ]++-- | Emit a call to @memmove@.+emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()+emitMemmoveCall dst src n align = do+    emitPrimCall+        [ {- no results -} ]+        (MO_Memmove (alignmentBytes align))+        [ dst, src, n ]++-- | Emit a call to @memset@.  The second argument must fit inside an+-- unsigned char.+emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()+emitMemsetCall dst c n align = do+    emitPrimCall+        [ {- no results -} ]+        (MO_Memset (alignmentBytes align))+        [ dst, c, n ]++emitMemcmpCall :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()+emitMemcmpCall res ptr1 ptr2 n align = do+    -- 'MO_Memcmp' is assumed to return an 32bit 'CInt' because all+    -- code-gens currently call out to the @memcmp(3)@ C function.+    -- This was easier than moving the sign-extensions into+    -- all the code-gens.+    dflags <- getDynFlags+    let is32Bit = typeWidth (localRegType res) == W32++    cres <- if is32Bit+              then return res+              else newTemp b32++    emitPrimCall+        [ cres ]+        (MO_Memcmp align)+        [ ptr1, ptr2, n ]++    unless is32Bit $ do+      emit $ mkAssign (CmmLocal res)+                      (CmmMachOp+                         (mo_s_32ToWord dflags)+                         [(CmmReg (CmmLocal cres))])++emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitBSwapCall res x width = do+    emitPrimCall+        [ res ]+        (MO_BSwap width)+        [ x ]++emitBRevCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitBRevCall res x width = do+    emitPrimCall+        [ res ]+        (MO_BRev width)+        [ x ]++emitPopCntCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitPopCntCall res x width = do+    emitPrimCall+        [ res ]+        (MO_PopCnt width)+        [ x ]++emitPdepCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()+emitPdepCall res x y width = do+    emitPrimCall+        [ res ]+        (MO_Pdep width)+        [ x, y ]++emitPextCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()+emitPextCall res x y width = do+    emitPrimCall+        [ res ]+        (MO_Pext width)+        [ x, y ]++emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitClzCall res x width = do+    emitPrimCall+        [ res ]+        (MO_Clz width)+        [ x ]++emitCtzCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitCtzCall res x width = do+    emitPrimCall+        [ res ]+        (MO_Ctz width)+        [ x ]++---------------------------------------------------------------------------+-- Pushing to the update remembered set+---------------------------------------------------------------------------++-- | Push a range of pointer-array elements that are about to be copied over to+-- the update remembered set.+emitCopyUpdRemSetPush :: DynFlags+                      -> WordOff    -- ^ array header size+                      -> CmmExpr    -- ^ destination array+                      -> CmmExpr    -- ^ offset in destination array (in words)+                      -> Int        -- ^ number of elements to copy+                      -> FCode ()+emitCopyUpdRemSetPush _dflags _hdr_size _dst _dst_off 0 = return ()+emitCopyUpdRemSetPush dflags hdr_size dst dst_off n =+    whenUpdRemSetEnabled dflags $ do+        updfr_off <- getUpdFrameOff+        graph <- mkCall lbl (NativeNodeCall,NativeReturn) [] args updfr_off []+        emit graph+  where+    lbl = mkLblExpr $ mkPrimCallLabel+          $ PrimCall (fsLit "stg_copyArray_barrier") rtsUnitId+    args =+      [ mkIntExpr dflags hdr_size+      , dst+      , dst_off+      , mkIntExpr dflags n+      ]
+ compiler/GHC/StgToCmm/Prof.hs view
@@ -0,0 +1,360 @@+-----------------------------------------------------------------------------+--+-- Code generation for profiling+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Prof (+        initCostCentres, ccType, ccsType,+        mkCCostCentre, mkCCostCentreStack,++        -- Cost-centre Profiling+        dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,+        enterCostCentreThunk, enterCostCentreFun,+        costCentreFrom,+        storeCurCCS,+        emitSetCCC,++        saveCurrentCostCentre, restoreCurrentCostCentre,++        -- Lag/drag/void stuff+        ldvEnter, ldvEnterClosure, ldvRecordCreate+  ) where++import GhcPrelude++import GHC.StgToCmm.Closure+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Monad+import SMRep++import MkGraph+import Cmm+import CmmUtils+import CLabel++import CostCentre+import DynFlags+import FastString+import Module+import Outputable++import Control.Monad+import Data.Char (ord)++-----------------------------------------------------------------------------+--+-- Cost-centre-stack Profiling+--+-----------------------------------------------------------------------------++-- Expression representing the current cost centre stack+ccsType :: DynFlags -> CmmType -- Type of a cost-centre stack+ccsType = bWord++ccType :: DynFlags -> CmmType -- Type of a cost centre+ccType = bWord++storeCurCCS :: CmmExpr -> CmmAGraph+storeCurCCS e = mkAssign cccsReg e++mkCCostCentre :: CostCentre -> CmmLit+mkCCostCentre cc = CmmLabel (mkCCLabel cc)++mkCCostCentreStack :: CostCentreStack -> CmmLit+mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)++costCentreFrom :: DynFlags+               -> CmmExpr         -- A closure pointer+               -> CmmExpr        -- The cost centre from that closure+costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags)++-- | The profiling header words in a static closure+staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]+staticProfHdr dflags ccs+ = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags]++-- | Profiling header words in a dynamic closure+dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]+dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags]++-- | Initialise the profiling field of an update frame+initUpdFrameProf :: CmmExpr -> FCode ()+initUpdFrameProf frame+  = ifProfiling $        -- frame->header.prof.ccs = CCCS+    do dflags <- getDynFlags+       emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) cccsExpr+        -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)+        -- is unnecessary because it is not used anyhow.++---------------------------------------------------------------------------+--         Saving and restoring the current cost centre+---------------------------------------------------------------------------++{-        Note [Saving the current cost centre]+        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The current cost centre is like a global register.  Like other+global registers, it's a caller-saves one.  But consider+        case (f x) of (p,q) -> rhs+Since 'f' may set the cost centre, we must restore it+before resuming rhs.  So we want code like this:+        local_cc = CCC  -- save+        r = f( x )+        CCC = local_cc  -- restore+That is, we explicitly "save" the current cost centre in+a LocalReg, local_cc; and restore it after the call. The+C-- infrastructure will arrange to save local_cc across the+call.++The same goes for join points;+        let j x = join-stuff+        in blah-blah+We want this kind of code:+        local_cc = CCC  -- save+        blah-blah+     J:+        CCC = local_cc  -- restore+-}++saveCurrentCostCentre :: FCode (Maybe LocalReg)+        -- Returns Nothing if profiling is off+saveCurrentCostCentre+  = do dflags <- getDynFlags+       if not (gopt Opt_SccProfilingOn dflags)+           then return Nothing+           else do local_cc <- newTemp (ccType dflags)+                   emitAssign (CmmLocal local_cc) cccsExpr+                   return (Just local_cc)++restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()+restoreCurrentCostCentre Nothing+  = return ()+restoreCurrentCostCentre (Just local_cc)+  = emit (storeCurCCS (CmmReg (CmmLocal local_cc)))+++-------------------------------------------------------------------------------+-- Recording allocation in a cost centre+-------------------------------------------------------------------------------++-- | Record the allocation of a closure.  The CmmExpr is the cost+-- centre stack to which to attribute the allocation.+profDynAlloc :: SMRep -> CmmExpr -> FCode ()+profDynAlloc rep ccs+  = ifProfiling $+    do dflags <- getDynFlags+       profAlloc (mkIntExpr dflags (heapClosureSizeW dflags rep)) ccs++-- | Record the allocation of a closure (size is given by a CmmExpr)+-- The size must be in words, because the allocation counter in a CCS counts+-- in words.+profAlloc :: CmmExpr -> CmmExpr -> FCode ()+profAlloc words ccs+  = ifProfiling $+        do dflags <- getDynFlags+           let alloc_rep = rEP_CostCentreStack_mem_alloc dflags+           emit (addToMemE alloc_rep+                       (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags))+                       (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $+                         [CmmMachOp (mo_wordSub dflags) [words,+                                                         mkIntExpr dflags (profHdrSize dflags)]]))+                       -- subtract the "profiling overhead", which is the+                       -- profiling header in a closure.++-- -----------------------------------------------------------------------+-- Setting the current cost centre on entry to a closure++enterCostCentreThunk :: CmmExpr -> FCode ()+enterCostCentreThunk closure =+  ifProfiling $ do+      dflags <- getDynFlags+      emit $ storeCurCCS (costCentreFrom dflags closure)++enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()+enterCostCentreFun ccs closure =+  ifProfiling $ do+    if isCurrentCCS ccs+       then do dflags <- getDynFlags+               emitRtsCall rtsUnitId (fsLit "enterFunCCS")+                   [(baseExpr, AddrHint),+                    (costCentreFrom dflags closure, AddrHint)] False+       else return () -- top-level function, nothing to do++ifProfiling :: FCode () -> FCode ()+ifProfiling code+  = do dflags <- getDynFlags+       if gopt Opt_SccProfilingOn dflags+           then code+           else return ()++ifProfilingL :: DynFlags -> [a] -> [a]+ifProfilingL dflags xs+  | gopt Opt_SccProfilingOn dflags = xs+  | otherwise                      = []+++---------------------------------------------------------------+--        Initialising Cost Centres & CCSs+---------------------------------------------------------------++initCostCentres :: CollectedCCs -> FCode ()+-- Emit the declarations+initCostCentres (local_CCs, singleton_CCSs)+  = do dflags <- getDynFlags+       when (gopt Opt_SccProfilingOn dflags) $+           do mapM_ emitCostCentreDecl local_CCs+              mapM_ emitCostCentreStackDecl singleton_CCSs+++emitCostCentreDecl :: CostCentre -> FCode ()+emitCostCentreDecl cc = do+  { dflags <- getDynFlags+  ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF+               | otherwise  = zero dflags+                        -- NB. bytesFS: we want the UTF-8 bytes here (#5559)+  ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)+  ; modl  <- newByteStringCLit (bytesFS $ Module.moduleNameFS+                                        $ Module.moduleName+                                        $ cc_mod cc)+  ; loc <- newByteStringCLit $ bytesFS $ mkFastString $+                   showPpr dflags (costCentreSrcSpan cc)+           -- XXX going via FastString to get UTF-8 encoding is silly+  ; let+     lits = [ zero dflags,           -- StgInt ccID,+              label,        -- char *label,+              modl,        -- char *module,+              loc,      -- char *srcloc,+              zero64,   -- StgWord64 mem_alloc+              zero dflags,     -- StgWord time_ticks+              is_caf,   -- StgInt is_caf+              zero dflags      -- struct _CostCentre *link+            ]+  ; emitDataLits (mkCCLabel cc) lits+  }++emitCostCentreStackDecl :: CostCentreStack -> FCode ()+emitCostCentreStackDecl ccs+  = case maybeSingletonCCS ccs of+    Just cc ->+        do dflags <- getDynFlags+           let mk_lits cc = zero dflags :+                            mkCCostCentre cc :+                            replicate (sizeof_ccs_words dflags - 2) (zero dflags)+                -- Note: to avoid making any assumptions about how the+                -- C compiler (that compiles the RTS, in particular) does+                -- layouts of structs containing long-longs, simply+                -- pad out the struct with zero words until we hit the+                -- size of the overall struct (which we get via DerivedConstants.h)+           emitDataLits (mkCCSLabel ccs) (mk_lits cc)+    Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)++zero :: DynFlags -> CmmLit+zero dflags = mkIntCLit dflags 0+zero64 :: CmmLit+zero64 = CmmInt 0 W64++sizeof_ccs_words :: DynFlags -> Int+sizeof_ccs_words dflags+    -- round up to the next word.+  | ms == 0   = ws+  | otherwise = ws + 1+  where+   (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags++-- ---------------------------------------------------------------------------+-- Set the current cost centre stack++emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()+emitSetCCC cc tick push+ = do dflags <- getDynFlags+      if not (gopt Opt_SccProfilingOn dflags)+          then return ()+          else do tmp <- newTemp (ccsType dflags)+                  pushCostCentre tmp cccsExpr cc+                  when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))+                  when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))++pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()+pushCostCentre result ccs cc+  = emitRtsCallWithResult result AddrHint+        rtsUnitId+        (fsLit "pushCostCentre") [(ccs,AddrHint),+                                (CmmLit (mkCCostCentre cc), AddrHint)]+        False++bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph+bumpSccCount dflags ccs+  = addToMem (rEP_CostCentreStack_scc_count dflags)+         (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1++-----------------------------------------------------------------------------+--+--                Lag/drag/void stuff+--+-----------------------------------------------------------------------------++--+-- Initial value for the LDV field in a static closure+--+staticLdvInit :: DynFlags -> CmmLit+staticLdvInit = zeroCLit++--+-- Initial value of the LDV field in a dynamic closure+--+dynLdvInit :: DynFlags -> CmmExpr+dynLdvInit dflags =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE+  CmmMachOp (mo_wordOr dflags) [+      CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)],+      CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags))+  ]++--+-- Initialise the LDV word of a new closure+--+ldvRecordCreate :: CmmExpr -> FCode ()+ldvRecordCreate closure = do+  dflags <- getDynFlags+  emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags)++--+-- | Called when a closure is entered, marks the closure as having+-- been "used".  The closure is not an "inherently used" one.  The+-- closure is not @IND@ because that is not considered for LDV profiling.+--+ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode ()+ldvEnterClosure closure_info node_reg = do+    dflags <- getDynFlags+    let tag = funTag dflags closure_info+    -- don't forget to substract node's tag+    ldvEnter (cmmOffsetB dflags (CmmReg node_reg) (-tag))++ldvEnter :: CmmExpr -> FCode ()+-- Argument is a closure pointer+ldvEnter cl_ptr = do+    dflags <- getDynFlags+    let -- don't forget to substract node's tag+        ldv_wd = ldvWord dflags cl_ptr+        new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))+                                                         (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags))))+                                      (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags))))+    ifProfiling $+         -- if (era > 0) {+         --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |+         --                era | LDV_STATE_USE }+        emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)])+                     (mkStore ldv_wd new_ldv_wd)+                     mkNop++loadEra :: DynFlags -> CmmExpr+loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags))+    [CmmLoad (mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "era")))+             (cInt dflags)]++ldvWord :: DynFlags -> CmmExpr -> CmmExpr+-- Takes the address of a closure, and returns+-- the address of the LDV word in the closure+ldvWord dflags closure_ptr+    = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags)
+ compiler/GHC/StgToCmm/Ticky.hs view
@@ -0,0 +1,682 @@+{-# LANGUAGE BangPatterns #-}++-----------------------------------------------------------------------------+--+-- Code generation for ticky-ticky profiling+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++{- OVERVIEW: ticky ticky profiling++Please see+https://gitlab.haskell.org/ghc/ghc/wikis/debugging/ticky-ticky and also+edit it and the rest of this comment to keep them up-to-date if you+change ticky-ticky. Thanks!++ *** All allocation ticky numbers are in bytes. ***++Some of the relevant source files:++       ***not necessarily an exhaustive list***++  * some codeGen/ modules import this one++  * this module imports cmm/CLabel.hs to manage labels++  * cmm/CmmParse.y expands some macros using generators defined in+    this module++  * includes/stg/Ticky.h declares all of the global counters++  * includes/rts/Ticky.h declares the C data type for an+    STG-declaration's counters++  * some macros defined in includes/Cmm.h (and used within the RTS's+    CMM code) update the global ticky counters++  * at the end of execution rts/Ticky.c generates the final report+    +RTS -r<report-file> -RTS++The rts/Ticky.c function that generates the report includes an+STG-declaration's ticky counters if++  * that declaration was entered, or++  * it was allocated (if -ticky-allocd)++On either of those events, the counter is "registered" by adding it to+a linked list; cf the CMM generated by registerTickyCtr.++Ticky-ticky profiling has evolved over many years. Many of the+counters from its most sophisticated days are no longer+active/accurate. As the RTS has changed, sometimes the ticky code for+relevant counters was not accordingly updated. Unfortunately, neither+were the comments.++As of March 2013, there still exist deprecated code and comments in+the code generator as well as the RTS because:++  * I don't know what is out-of-date versus merely commented out for+    momentary convenience, and++  * someone else might know how to repair it!++-}++module GHC.StgToCmm.Ticky (+  withNewTickyCounterFun,+  withNewTickyCounterLNE,+  withNewTickyCounterThunk,+  withNewTickyCounterStdThunk,+  withNewTickyCounterCon,++  tickyDynAlloc,+  tickyAllocHeap,++  tickyAllocPrim,+  tickyAllocThunk,+  tickyAllocPAP,+  tickyHeapCheck,+  tickyStackCheck,++  tickyUnknownCall, tickyDirectCall,++  tickyPushUpdateFrame,+  tickyUpdateFrameOmitted,++  tickyEnterDynCon,+  tickyEnterStaticCon,+  tickyEnterViaNode,++  tickyEnterFun,+  tickyEnterThunk, tickyEnterStdThunk,        -- dynamic non-value+                                              -- thunks only+  tickyEnterLNE,++  tickyUpdateBhCaf,+  tickyBlackHole,+  tickyUnboxedTupleReturn,+  tickyReturnOldCon, tickyReturnNewCon,++  tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,+  tickySlowCall, tickySlowCallPat,+  ) where++import GhcPrelude++import GHC.StgToCmm.ArgRep    ( slowCallPattern , toArgRep , argRepString )+import GHC.StgToCmm.Closure+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Monad++import StgSyn+import CmmExpr+import MkGraph+import CmmUtils+import CLabel+import SMRep++import Module+import Name+import Id+import BasicTypes+import FastString+import Outputable+import Util++import DynFlags++-- Turgid imports for showTypeCategory+import PrelNames+import TcType+import TyCon+import Predicate++import Data.Maybe+import qualified Data.Char+import Control.Monad ( when )++-----------------------------------------------------------------------------+--+-- Ticky-ticky profiling+--+-----------------------------------------------------------------------------++data TickyClosureType+    = TickyFun+        Bool -- True <-> single entry+    | TickyCon+    | TickyThunk+        Bool -- True <-> updateable+        Bool -- True <-> standard thunk (AP or selector), has no entry counter+    | TickyLNE++withNewTickyCounterFun :: Bool -> Name  -> [NonVoid Id] -> FCode a -> FCode a+withNewTickyCounterFun single_entry = withNewTickyCounter (TickyFun single_entry)++withNewTickyCounterLNE :: Name  -> [NonVoid Id] -> FCode a -> FCode a+withNewTickyCounterLNE nm args code = do+  b <- tickyLNEIsOn+  if not b then code else withNewTickyCounter TickyLNE nm args code++thunkHasCounter :: Bool -> FCode Bool+thunkHasCounter isStatic = do+  b <- tickyDynThunkIsOn+  pure (not isStatic && b)++withNewTickyCounterThunk+  :: Bool -- ^ static+  -> Bool -- ^ updateable+  -> Name+  -> FCode a+  -> FCode a+withNewTickyCounterThunk isStatic isUpdatable name code = do+    has_ctr <- thunkHasCounter isStatic+    if not has_ctr+      then code+      else withNewTickyCounter (TickyThunk isUpdatable False) name [] code++withNewTickyCounterStdThunk+  :: Bool -- ^ updateable+  -> Name+  -> FCode a+  -> FCode a+withNewTickyCounterStdThunk isUpdatable name code = do+    has_ctr <- thunkHasCounter False+    if not has_ctr+      then code+      else withNewTickyCounter (TickyThunk isUpdatable True) name [] code++withNewTickyCounterCon+  :: Name+  -> FCode a+  -> FCode a+withNewTickyCounterCon name code = do+    has_ctr <- thunkHasCounter False+    if not has_ctr+      then code+      else withNewTickyCounter TickyCon name [] code++-- args does not include the void arguments+withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a+withNewTickyCounter cloType name args m = do+  lbl <- emitTickyCounter cloType name args+  setTickyCtrLabel lbl m++emitTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode CLabel+emitTickyCounter cloType name args+  = let ctr_lbl = mkRednCountsLabel name in+    (>> return ctr_lbl) $+    ifTicky $ do+        { dflags <- getDynFlags+        ; parent <- getTickyCtrLabel+        ; mod_name <- getModuleName++          -- When printing the name of a thing in a ticky file, we+          -- want to give the module name even for *local* things.  We+          -- print just "x (M)" rather that "M.x" to distinguish them+          -- from the global kind.+        ; let ppr_for_ticky_name :: SDoc+              ppr_for_ticky_name =+                let n = ppr name+                    ext = case cloType of+                              TickyFun single_entry -> parens $ hcat $ punctuate comma $+                                  [text "fun"] ++ [text "se"|single_entry]+                              TickyCon -> parens (text "con")+                              TickyThunk upd std -> parens $ hcat $ punctuate comma $+                                  [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std]+                              TickyLNE | isInternalName name -> parens (text "LNE")+                                       | otherwise -> panic "emitTickyCounter: how is this an external LNE?"+                    p = case hasHaskellName parent of+                            -- NB the default "top" ticky ctr does not+                            -- have a Haskell name+                          Just pname -> text "in" <+> ppr (nameUnique pname)+                          _ -> empty+                in if isInternalName name+                   then n <+> parens (ppr mod_name) <+> ext <+> p+                   else n <+> ext <+> p++        ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name+        ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args+        ; emitDataLits ctr_lbl+        -- Must match layout of includes/rts/Ticky.h's StgEntCounter+        --+        -- krc: note that all the fields are I32 now; some were I16+        -- before, but the code generator wasn't handling that+        -- properly and it led to chaos, panic and disorder.+            [ mkIntCLit dflags 0,               -- registered?+              mkIntCLit dflags (length args),   -- Arity+              mkIntCLit dflags 0,               -- Heap allocated for this thing+              fun_descr_lit,+              arg_descr_lit,+              zeroCLit dflags,          -- Entries into this thing+              zeroCLit dflags,          -- Heap allocated by this thing+              zeroCLit dflags                   -- Link to next StgEntCounter+            ]+        }++-- -----------------------------------------------------------------------------+-- Ticky stack frames++tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode ()+tickyPushUpdateFrame    = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr")+tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")++-- -----------------------------------------------------------------------------+-- Ticky entries++-- NB the name-specific entries are only available for names that have+-- dedicated Cmm code. As far as I know, this just rules out+-- constructor thunks. For them, there is no CMM code block to put the+-- bump of name-specific ticky counter into. On the other hand, we can+-- still track allocation their allocation.++tickyEnterDynCon, tickyEnterStaticCon, tickyEnterViaNode :: FCode ()+tickyEnterDynCon      = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")+tickyEnterStaticCon   = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr")+tickyEnterViaNode     = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr")++tickyEnterThunk :: ClosureInfo -> FCode ()+tickyEnterThunk cl_info+  = ifTicky $ do+    { bumpTickyCounter ctr+    ; has_ctr <- thunkHasCounter static+    ; when has_ctr $ do+      ticky_ctr_lbl <- getTickyCtrLabel+      registerTickyCtrAtEntryDyn ticky_ctr_lbl+      bumpTickyEntryCount ticky_ctr_lbl }+  where+    updatable = closureSingleEntry cl_info+    static    = isStaticClosure cl_info++    ctr | static    = if updatable then fsLit "ENT_STATIC_THK_SINGLE_ctr"+                                   else fsLit "ENT_STATIC_THK_MANY_ctr"+        | otherwise = if updatable then fsLit "ENT_DYN_THK_SINGLE_ctr"+                                   else fsLit "ENT_DYN_THK_MANY_ctr"++tickyEnterStdThunk :: ClosureInfo -> FCode ()+tickyEnterStdThunk = tickyEnterThunk++tickyBlackHole :: Bool{-updatable-} -> FCode ()+tickyBlackHole updatable+  = ifTicky (bumpTickyCounter ctr)+  where+    ctr | updatable = (fsLit "UPD_BH_SINGLE_ENTRY_ctr")+        | otherwise = (fsLit "UPD_BH_UPDATABLE_ctr")++tickyUpdateBhCaf :: ClosureInfo -> FCode ()+tickyUpdateBhCaf cl_info+  = ifTicky (bumpTickyCounter ctr)+  where+    ctr | closureUpdReqd cl_info = (fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr")+        | otherwise              = (fsLit "UPD_CAF_BH_UPDATABLE_ctr")++tickyEnterFun :: ClosureInfo -> FCode ()+tickyEnterFun cl_info = ifTicky $ do+  ctr_lbl <- getTickyCtrLabel++  if isStaticClosure cl_info+    then do bumpTickyCounter (fsLit "ENT_STATIC_FUN_DIRECT_ctr")+            registerTickyCtr ctr_lbl+    else do bumpTickyCounter (fsLit "ENT_DYN_FUN_DIRECT_ctr")+            registerTickyCtrAtEntryDyn ctr_lbl++  bumpTickyEntryCount ctr_lbl++tickyEnterLNE :: FCode ()+tickyEnterLNE = ifTicky $ do+  bumpTickyCounter (fsLit "ENT_LNE_ctr")+  ifTickyLNE $ do+    ctr_lbl <- getTickyCtrLabel+    registerTickyCtr ctr_lbl+    bumpTickyEntryCount ctr_lbl++-- needn't register a counter upon entry if+--+-- 1) it's for a dynamic closure, and+--+-- 2) -ticky-allocd is on+--+-- since the counter was registered already upon being alloc'd+registerTickyCtrAtEntryDyn :: CLabel -> FCode ()+registerTickyCtrAtEntryDyn ctr_lbl = do+  already_registered <- tickyAllocdIsOn+  when (not already_registered) $ registerTickyCtr ctr_lbl++registerTickyCtr :: CLabel -> FCode ()+-- Register a ticky counter+--   if ( ! f_ct.registeredp ) {+--          f_ct.link = ticky_entry_ctrs;       /* hook this one onto the front of the list */+--          ticky_entry_ctrs = & (f_ct);        /* mark it as "registered" */+--          f_ct.registeredp = 1 }+registerTickyCtr ctr_lbl = do+  dflags <- getDynFlags+  let+    -- krc: code generator doesn't handle Not, so we test for Eq 0 instead+    test = CmmMachOp (MO_Eq (wordWidth dflags))+              [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl+                                (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags),+               zeroExpr dflags]+    register_stmts+      = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags)))+                   (CmmLoad ticky_entry_ctrs (bWord dflags))+        , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl)+        , mkStore (CmmLit (cmmLabelOffB ctr_lbl+                                (oFFSET_StgEntCounter_registeredp dflags)))+                   (mkIntExpr dflags 1) ]+    ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "ticky_entry_ctrs"))+  emit =<< mkCmmIfThen test (catAGraphs register_stmts)++tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()+tickyReturnOldCon arity+  = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr")+                 ; bumpHistogram    (fsLit "RET_OLD_hst") arity }+tickyReturnNewCon arity+  = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr")+                 ; bumpHistogram    (fsLit "RET_NEW_hst") arity }++tickyUnboxedTupleReturn :: RepArity -> FCode ()+tickyUnboxedTupleReturn arity+  = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")+                 ; bumpHistogram    (fsLit "RET_UNBOXED_TUP_hst") arity }++-- -----------------------------------------------------------------------------+-- Ticky calls++-- Ticks at a *call site*:+tickyDirectCall :: RepArity -> [StgArg] -> FCode ()+tickyDirectCall arity args+  | args `lengthIs` arity = tickyKnownCallExact+  | otherwise = do tickyKnownCallExtraArgs+                   tickySlowCallPat (map argPrimRep (drop arity args))++tickyKnownCallTooFewArgs :: FCode ()+tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")++tickyKnownCallExact :: FCode ()+tickyKnownCallExact      = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr")++tickyKnownCallExtraArgs :: FCode ()+tickyKnownCallExtraArgs  = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr")++tickyUnknownCall :: FCode ()+tickyUnknownCall         = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr")++-- Tick for the call pattern at slow call site (i.e. in addition to+-- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)+tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()+tickySlowCall _ [] = return ()+tickySlowCall lf_info args = do+ -- see Note [Ticky for slow calls]+ if isKnownFun lf_info+   then tickyKnownCallTooFewArgs+   else tickyUnknownCall+ tickySlowCallPat (map argPrimRep args)++tickySlowCallPat :: [PrimRep] -> FCode ()+tickySlowCallPat args = ifTicky $+  let argReps = map toArgRep args+      (_, n_matched) = slowCallPattern argReps+  in if n_matched > 0 && args `lengthIs` n_matched+     then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps+     else bumpTickyCounter $ fsLit "VERY_SLOW_CALL_ctr"++{-++Note [Ticky for slow calls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Terminology is unfortunately a bit mixed up for these calls. codeGen+uses "slow call" to refer to unknown calls and under-saturated known+calls.++Nowadays, though (ie as of the eval/apply paper), the significantly+slower calls are actually just a subset of these: the ones with no+built-in argument pattern (cf GHC.StgToCmm.ArgRep.slowCallPattern)++So for ticky profiling, we split slow calls into+"SLOW_CALL_fast_<pattern>_ctr" (those matching a built-in pattern) and+VERY_SLOW_CALL_ctr (those without a built-in pattern; these are very+bad for both space and time).++-}++-- -----------------------------------------------------------------------------+-- Ticky allocation++tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()+-- Called when doing a dynamic heap allocation; the LambdaFormInfo+-- used to distinguish between closure types+--+-- TODO what else to count while we're here?+tickyDynAlloc mb_id rep lf = ifTicky $ getDynFlags >>= \dflags ->+  let bytes = wORD_SIZE dflags * heapClosureSizeW dflags rep++      countGlobal tot ctr = do+        bumpTickyCounterBy tot bytes+        bumpTickyCounter   ctr+      countSpecific = ifTickyAllocd $ case mb_id of+        Nothing -> return ()+        Just id -> do+          let ctr_lbl = mkRednCountsLabel (idName id)+          registerTickyCtr ctr_lbl+          bumpTickyAllocd ctr_lbl bytes++  -- TODO are we still tracking "good stuff" (_gds) versus+  -- administrative (_adm) versus slop (_slp)? I'm going with all _gds+  -- for now, since I don't currently know neither if we do nor how to+  -- distinguish. NSF Mar 2013++  in case () of+    _ | isConRep rep   ->+          ifTickyDynThunk countSpecific >>+          countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr")+      | isThunkRep rep ->+          ifTickyDynThunk countSpecific >>+          if lfUpdatable lf+          then countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_UP_THK_ctr")+          else countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_SE_THK_ctr")+      | isFunRep   rep ->+          countSpecific >>+          countGlobal (fsLit "ALLOC_FUN_gds") (fsLit "ALLOC_FUN_ctr")+      | otherwise      -> panic "How is this heap object not a con, thunk, or fun?"++++tickyAllocHeap ::+  Bool -> -- is this a genuine allocation? As opposed to+          -- GHC.StgToCmm.Layout.adjustHpBackwards+  VirtualHpOffset -> FCode ()+-- Called when doing a heap check [TICK_ALLOC_HEAP]+-- Must be lazy in the amount of allocation!+tickyAllocHeap genuine hp+  = ifTicky $+    do  { dflags <- getDynFlags+        ; ticky_ctr <- getTickyCtrLabel+        ; emit $ catAGraphs $+            -- only test hp from within the emit so that the monadic+            -- computation itself is not strict in hp (cf knot in+            -- GHC.StgToCmm.Monad.getHeapUsage)+          if hp == 0 then []+          else let !bytes = wORD_SIZE dflags * hp in [+            -- Bump the allocation total in the closure's StgEntCounter+            addToMem (rEP_StgEntCounter_allocs dflags)+                     (CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags)))+                     bytes,+            -- Bump the global allocation total ALLOC_HEAP_tot+            addToMemLbl (bWord dflags)+                        (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_tot"))+                        bytes,+            -- Bump the global allocation counter ALLOC_HEAP_ctr+            if not genuine then mkNop+            else addToMemLbl (bWord dflags)+                             (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_ctr"))+                             1+            ]}+++--------------------------------------------------------------------------------+-- these three are only called from CmmParse.y (ie ultimately from the RTS)++-- the units are bytes++tickyAllocPrim :: CmmExpr  -- ^ size of the full header, in bytes+               -> CmmExpr  -- ^ size of the payload, in bytes+               -> CmmExpr -> FCode ()+tickyAllocPrim _hdr _goods _slop = ifTicky $ do+  bumpTickyCounter    (fsLit "ALLOC_PRIM_ctr")+  bumpTickyCounterByE (fsLit "ALLOC_PRIM_adm") _hdr+  bumpTickyCounterByE (fsLit "ALLOC_PRIM_gds") _goods+  bumpTickyCounterByE (fsLit "ALLOC_PRIM_slp") _slop++tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()+tickyAllocThunk _goods _slop = ifTicky $ do+    -- TODO is it ever called with a Single-Entry thunk?+  bumpTickyCounter    (fsLit "ALLOC_UP_THK_ctr")+  bumpTickyCounterByE (fsLit "ALLOC_THK_gds") _goods+  bumpTickyCounterByE (fsLit "ALLOC_THK_slp") _slop++tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()+tickyAllocPAP _goods _slop = ifTicky $ do+  bumpTickyCounter    (fsLit "ALLOC_PAP_ctr")+  bumpTickyCounterByE (fsLit "ALLOC_PAP_gds") _goods+  bumpTickyCounterByE (fsLit "ALLOC_PAP_slp") _slop++tickyHeapCheck :: FCode ()+tickyHeapCheck = ifTicky $ bumpTickyCounter (fsLit "HEAP_CHK_ctr")++tickyStackCheck :: FCode ()+tickyStackCheck = ifTicky $ bumpTickyCounter (fsLit "STK_CHK_ctr")++-- -----------------------------------------------------------------------------+-- Ticky utils++ifTicky :: FCode () -> FCode ()+ifTicky code =+  getDynFlags >>= \dflags -> when (gopt Opt_Ticky dflags) code++tickyAllocdIsOn :: FCode Bool+tickyAllocdIsOn = gopt Opt_Ticky_Allocd `fmap` getDynFlags++tickyLNEIsOn :: FCode Bool+tickyLNEIsOn = gopt Opt_Ticky_LNE `fmap` getDynFlags++tickyDynThunkIsOn :: FCode Bool+tickyDynThunkIsOn = gopt Opt_Ticky_Dyn_Thunk `fmap` getDynFlags++ifTickyAllocd :: FCode () -> FCode ()+ifTickyAllocd code = tickyAllocdIsOn >>= \b -> when b code++ifTickyLNE :: FCode () -> FCode ()+ifTickyLNE code = tickyLNEIsOn >>= \b -> when b code++ifTickyDynThunk :: FCode () -> FCode ()+ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code++bumpTickyCounter :: FastString -> FCode ()+bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsUnitId lbl)++bumpTickyCounterBy :: FastString -> Int -> FCode ()+bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsUnitId lbl)++bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()+bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsUnitId lbl)++bumpTickyEntryCount :: CLabel -> FCode ()+bumpTickyEntryCount lbl = do+  dflags <- getDynFlags+  bumpTickyLit (cmmLabelOffB lbl (oFFSET_StgEntCounter_entry_count dflags))++bumpTickyAllocd :: CLabel -> Int -> FCode ()+bumpTickyAllocd lbl bytes = do+  dflags <- getDynFlags+  bumpTickyLitBy (cmmLabelOffB lbl (oFFSET_StgEntCounter_allocd dflags)) bytes++bumpTickyLbl :: CLabel -> FCode ()+bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1++bumpTickyLblBy :: CLabel -> Int -> FCode ()+bumpTickyLblBy lhs = bumpTickyLitBy (cmmLabelOffB lhs 0)++bumpTickyLblByE :: CLabel -> CmmExpr -> FCode ()+bumpTickyLblByE lhs = bumpTickyLitByE (cmmLabelOffB lhs 0)++bumpTickyLit :: CmmLit -> FCode ()+bumpTickyLit lhs = bumpTickyLitBy lhs 1++bumpTickyLitBy :: CmmLit -> Int -> FCode ()+bumpTickyLitBy lhs n = do+  dflags <- getDynFlags+  emit (addToMem (bWord dflags) (CmmLit lhs) n)++bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()+bumpTickyLitByE lhs e = do+  dflags <- getDynFlags+  emit (addToMemE (bWord dflags) (CmmLit lhs) e)++bumpHistogram :: FastString -> Int -> FCode ()+bumpHistogram lbl n = do+    dflags <- getDynFlags+    let offset = n `min` (tICKY_BIN_COUNT dflags - 1)+    emit (addToMem (bWord dflags)+           (cmmIndexExpr dflags+                (wordWidth dflags)+                (CmmLit (CmmLabel (mkCmmDataLabel rtsUnitId lbl)))+                (CmmLit (CmmInt (fromIntegral offset) (wordWidth dflags))))+           1)++------------------------------------------------------------------+-- Showing the "type category" for ticky-ticky profiling++showTypeCategory :: Type -> Char+  {-+        +           dictionary++        >           function++        {C,I,F,D,W} char, int, float, double, word+        {c,i,f,d,w} unboxed ditto++        T           tuple++        P           other primitive type+        p           unboxed ditto++        L           list+        E           enumeration type+        S           other single-constructor type+        M           other multi-constructor data-con type++        .           other type++        -           reserved for others to mark as "uninteresting"++  Accurate as of Mar 2013, but I eliminated the Array category instead+  of updating it, for simplicity. It's in P/p, I think --NSF++    -}+showTypeCategory ty+  | isDictTy ty = '+'+  | otherwise = case tcSplitTyConApp_maybe ty of+  Nothing -> '.'+  Just (tycon, _) ->+    (if isUnliftedTyCon tycon then Data.Char.toLower else id) $+    let anyOf us = getUnique tycon `elem` us in+    case () of+      _ | anyOf [funTyConKey] -> '>'+        | anyOf [charPrimTyConKey, charTyConKey] -> 'C'+        | anyOf [doublePrimTyConKey, doubleTyConKey] -> 'D'+        | anyOf [floatPrimTyConKey, floatTyConKey] -> 'F'+        | anyOf [intPrimTyConKey, int32PrimTyConKey, int64PrimTyConKey,+                 intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey+                ] -> 'I'+        | anyOf [wordPrimTyConKey, word32PrimTyConKey, word64PrimTyConKey, wordTyConKey,+                 word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey+                ] -> 'W'+        | anyOf [listTyConKey] -> 'L'+        | isTupleTyCon tycon       -> 'T'+        | isPrimTyCon tycon        -> 'P'+        | isEnumerationTyCon tycon -> 'E'+        | isJust (tyConSingleDataCon_maybe tycon) -> 'S'+        | otherwise -> 'M' -- oh, well...
+ compiler/GHC/StgToCmm/Utils.hs view
@@ -0,0 +1,620 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Code generator utilities; mostly monadic+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Utils (+        cgLit, mkSimpleLit,+        emitDataLits, mkDataLits,+        emitRODataLits, mkRODataLits,+        emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,+        assignTemp, newTemp,++        newUnboxedTupleRegs,++        emitMultiAssign, emitCmmLitSwitch, emitSwitch,++        tagToClosure, mkTaggedObjectLoad,++        callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,++        cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,+        cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,+        cmmOffsetExprW, cmmOffsetExprB,+        cmmRegOffW, cmmRegOffB,+        cmmLabelOffW, cmmLabelOffB,+        cmmOffsetW, cmmOffsetB,+        cmmOffsetLitW, cmmOffsetLitB,+        cmmLoadIndexW,+        cmmConstrTag1,++        cmmUntag, cmmIsTagged,++        addToMem, addToMemE, addToMemLblE, addToMemLbl,+        mkWordCLit,+        newStringCLit, newByteStringCLit,+        blankWord,++        -- * Update remembered set operations+        whenUpdRemSetEnabled,+        emitUpdRemSetPush,+        emitUpdRemSetPushThunk,+  ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.StgToCmm.Monad+import GHC.StgToCmm.Closure+import Cmm+import BlockId+import MkGraph+import GHC.Platform.Regs+import CLabel+import CmmUtils+import CmmSwitch+import GHC.StgToCmm.CgUtils++import ForeignCall+import IdInfo+import Type+import TyCon+import SMRep+import Module+import Literal+import Digraph+import Util+import Unique+import UniqSupply (MonadUnique(..))+import DynFlags+import FastString+import Outputable+import RepType++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS8+import qualified Data.Map as M+import Data.Char+import Data.List+import Data.Ord+++-------------------------------------------------------------------------+--+--      Literals+--+-------------------------------------------------------------------------++cgLit :: Literal -> FCode CmmLit+cgLit (LitString s) = newByteStringCLit s+ -- not unpackFS; we want the UTF-8 byte stream.+cgLit other_lit     = do dflags <- getDynFlags+                         return (mkSimpleLit dflags other_lit)++mkSimpleLit :: DynFlags -> Literal -> CmmLit+mkSimpleLit dflags (LitChar   c)                = CmmInt (fromIntegral (ord c))+                                                         (wordWidth dflags)+mkSimpleLit dflags LitNullAddr                  = zeroCLit dflags+mkSimpleLit dflags (LitNumber LitNumInt i _)    = CmmInt i (wordWidth dflags)+mkSimpleLit _      (LitNumber LitNumInt64 i _)  = CmmInt i W64+mkSimpleLit dflags (LitNumber LitNumWord i _)   = CmmInt i (wordWidth dflags)+mkSimpleLit _      (LitNumber LitNumWord64 i _) = CmmInt i W64+mkSimpleLit _      (LitFloat r)                 = CmmFloat r W32+mkSimpleLit _      (LitDouble r)                = CmmFloat r W64+mkSimpleLit _      (LitLabel fs ms fod)+  = let -- TODO: Literal labels might not actually be in the current package...+        labelSrc = ForeignLabelInThisPackage+    in CmmLabel (mkForeignLabel fs ms labelSrc fod)+-- NB: LitRubbish should have been lowered in "CoreToStg"+mkSimpleLit _      other = pprPanic "mkSimpleLit" (ppr other)++--------------------------------------------------------------------------+--+-- Incrementing a memory location+--+--------------------------------------------------------------------------++addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph+addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n++addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph+addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl))++addToMem :: CmmType     -- rep of the counter+         -> CmmExpr     -- Address+         -> Int         -- What to add (a word)+         -> CmmAGraph+addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep)))++addToMemE :: CmmType    -- rep of the counter+          -> CmmExpr    -- Address+          -> CmmExpr    -- What to add (a word-typed expression)+          -> CmmAGraph+addToMemE rep ptr n+  = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])+++-------------------------------------------------------------------------+--+--      Loading a field from an object,+--      where the object pointer is itself tagged+--+-------------------------------------------------------------------------++mkTaggedObjectLoad+  :: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph+-- (loadTaggedObjectField reg base off tag) generates assignment+--      reg = bitsK[ base + off - tag ]+-- where K is fixed by 'reg'+mkTaggedObjectLoad dflags reg base offset tag+  = mkAssign (CmmLocal reg)+             (CmmLoad (cmmOffsetB dflags+                                  (CmmReg (CmmLocal base))+                                  (offset - tag))+                      (localRegType reg))++-------------------------------------------------------------------------+--+--      Converting a closure tag to a closure for enumeration types+--      (this is the implementation of tagToEnum#).+--+-------------------------------------------------------------------------++tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr+tagToClosure dflags tycon tag+  = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (bWord dflags)+  where closure_tbl = CmmLit (CmmLabel lbl)+        lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs++-------------------------------------------------------------------------+--+--      Conditionals and rts calls+--+-------------------------------------------------------------------------++emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()+emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe++emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString+        -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()+emitRtsCallWithResult res hint pkg fun args safe+   = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe++-- Make a call to an RTS C procedure+emitRtsCallGen+   :: [(LocalReg,ForeignHint)]+   -> CLabel+   -> [(CmmExpr,ForeignHint)]+   -> Bool -- True <=> CmmSafe call+   -> FCode ()+emitRtsCallGen res lbl args safe+  = do { dflags <- getDynFlags+       ; updfr_off <- getUpdFrameOff+       ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags+       ; emit caller_save+       ; call updfr_off+       ; emit caller_load }+  where+    call updfr_off =+      if safe then+        emit =<< mkCmmCall fun_expr res' args' updfr_off+      else do+        let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn+        emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'+    (args', arg_hints) = unzip args+    (res',  res_hints) = unzip res+    fun_expr = mkLblExpr lbl+++-----------------------------------------------------------------------------+--+--      Caller-Save Registers+--+-----------------------------------------------------------------------------++-- Here we generate the sequence of saves/restores required around a+-- foreign call instruction.++-- TODO: reconcile with includes/Regs.h+--  * Regs.h claims that BaseReg should be saved last and loaded first+--    * This might not have been tickled before since BaseReg is callee save+--  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim+--+-- This code isn't actually used right now, because callerSaves+-- only ever returns true in the current universe for registers NOT in+-- system_regs (just do a grep for CALLER_SAVES in+-- includes/stg/MachRegs.h).  It's all one giant no-op, and for+-- good reason: having to save system registers on every foreign call+-- would be very expensive, so we avoid assigning them to those+-- registers when we add support for an architecture.+--+-- Note that the old code generator actually does more work here: it+-- also saves other global registers.  We can't (nor want) to do that+-- here, as we don't have liveness information.  And really, we+-- shouldn't be doing the workaround at this point in the pipeline, see+-- Note [Register parameter passing] and the ToDo on CmmCall in+-- cmm/CmmNode.hs.  Right now the workaround is to avoid inlining across+-- unsafe foreign calls in rewriteAssignments, but this is strictly+-- temporary.+callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph)+callerSaveVolatileRegs dflags = (caller_save, caller_load)+  where+    platform = targetPlatform dflags++    caller_save = catAGraphs (map callerSaveGlobalReg    regs_to_save)+    caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)++    system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery+                    {- ,SparkHd,SparkTl,SparkBase,SparkLim -}+                  , BaseReg ]++    regs_to_save = filter (callerSaves platform) system_regs++    callerSaveGlobalReg reg+        = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))++    callerRestoreGlobalReg reg+        = mkAssign (CmmGlobal reg)+                   (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg))+++-------------------------------------------------------------------------+--+--      Strings generate a top-level data block+--+-------------------------------------------------------------------------++emitDataLits :: CLabel -> [CmmLit] -> FCode ()+-- Emit a data-segment data block+emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits)++emitRODataLits :: CLabel -> [CmmLit] -> FCode ()+-- Emit a read-only data block+emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)++newStringCLit :: String -> FCode CmmLit+-- Make a global definition for the string,+-- and return its label+newStringCLit str = newByteStringCLit (BS8.pack str)++newByteStringCLit :: ByteString -> FCode CmmLit+newByteStringCLit bytes+  = do  { uniq <- newUnique+        ; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes+        ; emitDecl decl+        ; return lit }++-------------------------------------------------------------------------+--+--      Assigning expressions to temporaries+--+-------------------------------------------------------------------------++assignTemp :: CmmExpr -> FCode LocalReg+-- Make sure the argument is in a local register.+-- We don't bother being particularly aggressive with avoiding+-- unnecessary local registers, since we can rely on a later+-- optimization pass to inline as necessary (and skipping out+-- on things like global registers can be a little dangerous+-- due to them being trashed on foreign calls--though it means+-- the optimization pass doesn't have to do as much work)+assignTemp (CmmReg (CmmLocal reg)) = return reg+assignTemp e = do { dflags <- getDynFlags+                  ; uniq <- newUnique+                  ; let reg = LocalReg uniq (cmmExprType dflags e)+                  ; emitAssign (CmmLocal reg) e+                  ; return reg }++newTemp :: MonadUnique m => CmmType -> m LocalReg+newTemp rep = do { uniq <- getUniqueM+                 ; return (LocalReg uniq rep) }++newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])+-- Choose suitable local regs to use for the components+-- of an unboxed tuple that we are about to return to+-- the Sequel.  If the Sequel is a join point, using the+-- regs it wants will save later assignments.+newUnboxedTupleRegs res_ty+  = ASSERT( isUnboxedTupleType res_ty )+    do  { dflags <- getDynFlags+        ; sequel <- getSequel+        ; regs <- choose_regs dflags sequel+        ; ASSERT( regs `equalLength` reps )+          return (regs, map primRepForeignHint reps) }+  where+    reps = typePrimRep res_ty+    choose_regs _ (AssignTo regs _) = return regs+    choose_regs dflags _            = mapM (newTemp . primRepCmmType dflags) reps++++-------------------------------------------------------------------------+--      emitMultiAssign+-------------------------------------------------------------------------++emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()+-- Emit code to perform the assignments in the+-- input simultaneously, using temporary variables when necessary.++type Key  = Int+type Vrtx = (Key, Stmt) -- Give each vertex a unique number,+                        -- for fast comparison+type Stmt = (LocalReg, CmmExpr) -- r := e++-- We use the strongly-connected component algorithm, in which+--      * the vertices are the statements+--      * an edge goes from s1 to s2 iff+--              s1 assigns to something s2 uses+--        that is, if s1 should *follow* s2 in the final order++emitMultiAssign []    []    = return ()+emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs+emitMultiAssign regs rhss   = do+  dflags <- getDynFlags+  ASSERT2( equalLength regs rhss, ppr regs $$ ppr rhss )+    unscramble dflags ([1..] `zip` (regs `zip` rhss))++unscramble :: DynFlags -> [Vrtx] -> FCode ()+unscramble dflags vertices = mapM_ do_component components+  where+        edges :: [ Node Key Vrtx ]+        edges = [ DigraphNode vertex key1 (edges_from stmt1)+                | vertex@(key1, stmt1) <- vertices ]++        edges_from :: Stmt -> [Key]+        edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,+                                    stmt1 `mustFollow` stmt2 ]++        components :: [SCC Vrtx]+        components = stronglyConnCompFromEdgedVerticesUniq edges++        -- do_components deal with one strongly-connected component+        -- Not cyclic, or singleton?  Just do it+        do_component :: SCC Vrtx -> FCode ()+        do_component (AcyclicSCC (_,stmt))  = mk_graph stmt+        do_component (CyclicSCC [])         = panic "do_component"+        do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt++                -- Cyclic?  Then go via temporaries.  Pick one to+                -- break the loop and try again with the rest.+        do_component (CyclicSCC ((_,first_stmt) : rest)) = do+            dflags <- getDynFlags+            u <- newUnique+            let (to_tmp, from_tmp) = split dflags u first_stmt+            mk_graph to_tmp+            unscramble dflags rest+            mk_graph from_tmp++        split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt)+        split dflags uniq (reg, rhs)+          = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))+          where+            rep = cmmExprType dflags rhs+            tmp = LocalReg uniq rep++        mk_graph :: Stmt -> FCode ()+        mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs++        mustFollow :: Stmt -> Stmt -> Bool+        (reg, _) `mustFollow` (_, rhs) = regUsedIn dflags (CmmLocal reg) rhs++-------------------------------------------------------------------------+--      mkSwitch+-------------------------------------------------------------------------+++emitSwitch :: CmmExpr                      -- Tag to switch on+           -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches+           -> Maybe CmmAGraphScoped        -- Default branch (if any)+           -> ConTagZ -> ConTagZ           -- Min and Max possible values;+                                           -- behaviour outside this range is+                                           -- undefined+           -> FCode ()++-- First, two rather common cases in which there is no work to do+emitSwitch _ []         (Just code) _ _ = emit (fst code)+emitSwitch _ [(_,code)] Nothing     _ _ = emit (fst code)++-- Right, off we go+emitSwitch tag_expr branches mb_deflt lo_tag hi_tag = do+    join_lbl      <- newBlockId+    mb_deflt_lbl  <- label_default join_lbl mb_deflt+    branches_lbls <- label_branches join_lbl branches+    tag_expr'     <- assignTemp' tag_expr++    -- Sort the branches before calling mk_discrete_switch+    let branches_lbls' = [ (fromIntegral i, l) | (i,l) <- sortBy (comparing fst) branches_lbls ]+    let range = (fromIntegral lo_tag, fromIntegral hi_tag)++    emit $ mk_discrete_switch False tag_expr' branches_lbls' mb_deflt_lbl range++    emitLabel join_lbl++mk_discrete_switch :: Bool -- ^ Use signed comparisons+          -> CmmExpr+          -> [(Integer, BlockId)]+          -> Maybe BlockId+          -> (Integer, Integer)+          -> CmmAGraph++-- SINGLETON TAG RANGE: no case analysis to do+mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag)+  | lo_tag == hi_tag+  = ASSERT( tag == lo_tag )+    mkBranch lbl++-- SINGLETON BRANCH, NO DEFAULT: no case analysis to do+mk_discrete_switch _ _tag_expr [(_tag,lbl)] Nothing _+  = mkBranch lbl+        -- The simplifier might have eliminated a case+        --       so we may have e.g. case xs of+        --                               [] -> e+        -- In that situation we can be sure the (:) case+        -- can't happen, so no need to test++-- SOMETHING MORE COMPLICATED: defer to CmmImplementSwitchPlans+-- See Note [Cmm Switches, the general plan] in CmmSwitch+mk_discrete_switch signed tag_expr branches mb_deflt range+  = mkSwitch tag_expr $ mkSwitchTargets signed range mb_deflt (M.fromList branches)++divideBranches :: Ord a => [(a,b)] -> ([(a,b)], a, [(a,b)])+divideBranches branches = (lo_branches, mid, hi_branches)+  where+    -- 2 branches => n_branches `div` 2 = 1+    --            => branches !! 1 give the *second* tag+    -- There are always at least 2 branches here+    (mid,_) = branches !! (length branches `div` 2)+    (lo_branches, hi_branches) = span is_lo branches+    is_lo (t,_) = t < mid++--------------+emitCmmLitSwitch :: CmmExpr                    -- Tag to switch on+               -> [(Literal, CmmAGraphScoped)] -- Tagged branches+               -> CmmAGraphScoped              -- Default branch (always)+               -> FCode ()                     -- Emit the code+emitCmmLitSwitch _scrut []       deflt = emit $ fst deflt+emitCmmLitSwitch scrut  branches deflt = do+    scrut' <- assignTemp' scrut+    join_lbl <- newBlockId+    deflt_lbl <- label_code join_lbl deflt+    branches_lbls <- label_branches join_lbl branches++    dflags <- getDynFlags+    let cmm_ty = cmmExprType dflags scrut+        rep = typeWidth cmm_ty++    -- We find the necessary type information in the literals in the branches+    let signed = case head branches of+                    (LitNumber nt _ _, _) -> litNumIsSigned nt+                    _ -> False++    let range | signed    = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags)+              | otherwise = (0, tARGET_MAX_WORD dflags)++    if isFloatType cmm_ty+    then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls+    else emit $ mk_discrete_switch+        signed+        scrut'+        [(litValue lit,l) | (lit,l) <- branches_lbls]+        (Just deflt_lbl)+        range+    emitLabel join_lbl++-- | lower bound (inclusive), upper bound (exclusive)+type LitBound = (Maybe Literal, Maybe Literal)++noBound :: LitBound+noBound = (Nothing, Nothing)++mk_float_switch :: Width -> CmmExpr -> BlockId+              -> LitBound+              -> [(Literal,BlockId)]+              -> FCode CmmAGraph+mk_float_switch rep scrut deflt _bounds [(lit,blk)]+  = do dflags <- getDynFlags+       return $ mkCbranch (cond dflags) deflt blk Nothing+  where+    cond dflags = CmmMachOp ne [scrut, CmmLit cmm_lit]+      where+        cmm_lit = mkSimpleLit dflags lit+        ne      = MO_F_Ne rep++mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches+  = do dflags <- getDynFlags+       lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches+       hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches+       mkCmmIfThenElse (cond dflags) lo_blk hi_blk+  where+    (lo_branches, mid_lit, hi_branches) = divideBranches branches++    bounds_lo = (lo_bound, Just mid_lit)+    bounds_hi = (Just mid_lit, hi_bound)++    cond dflags = CmmMachOp lt [scrut, CmmLit cmm_lit]+      where+        cmm_lit = mkSimpleLit dflags mid_lit+        lt      = MO_F_Lt rep+++--------------+label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)+label_default _ Nothing+  = return Nothing+label_default join_lbl (Just code)+  = do lbl <- label_code join_lbl code+       return (Just lbl)++--------------+label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)]+label_branches _join_lbl []+  = return []+label_branches join_lbl ((tag,code):branches)+  = do lbl <- label_code join_lbl code+       branches' <- label_branches join_lbl branches+       return ((tag,lbl):branches')++--------------+label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId+--  label_code J code+--      generates+--  [L: code; goto J]+-- and returns L+label_code join_lbl (code,tsc) = do+    lbl <- newBlockId+    emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl, tsc)+    return lbl++--------------+assignTemp' :: CmmExpr -> FCode CmmExpr+assignTemp' e+  | isTrivialCmmExpr e = return e+  | otherwise = do+       dflags <- getDynFlags+       lreg <- newTemp (cmmExprType dflags e)+       let reg = CmmLocal lreg+       emitAssign reg e+       return (CmmReg reg)+++---------------------------------------------------------------------------+-- Pushing to the update remembered set+---------------------------------------------------------------------------++whenUpdRemSetEnabled :: DynFlags -> FCode a -> FCode ()+whenUpdRemSetEnabled dflags code = do+    do_it <- getCode code+    the_if <- mkCmmIfThenElse' is_enabled do_it mkNop (Just False)+    emit the_if+  where+    enabled = CmmLoad (CmmLit $ CmmLabel mkNonmovingWriteBarrierEnabledLabel) (bWord dflags)+    zero = zeroExpr dflags+    is_enabled = cmmNeWord dflags enabled zero++-- | Emit code to add an entry to a now-overwritten pointer to the update+-- remembered set.+emitUpdRemSetPush :: CmmExpr   -- ^ value of pointer which was overwritten+                  -> FCode ()+emitUpdRemSetPush ptr = do+    emitRtsCall+      rtsUnitId+      (fsLit "updateRemembSetPushClosure_")+      [(CmmReg (CmmGlobal BaseReg), AddrHint),+       (ptr, AddrHint)]+      False++emitUpdRemSetPushThunk :: CmmExpr -- ^ the thunk+                       -> FCode ()+emitUpdRemSetPushThunk ptr = do+    emitRtsCall+      rtsUnitId+      (fsLit "updateRemembSetPushThunk_")+      [(CmmReg (CmmGlobal BaseReg), AddrHint),+       (ptr, AddrHint)]+      False
+ compiler/GHC/ThToHs.hs view
@@ -0,0 +1,2027 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++This module converts Template Haskell syntax into Hs syntax+-}++{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module GHC.ThToHs+   ( convertToHsExpr+   , convertToPat+   , convertToHsDecls+   , convertToHsType+   , thRdrNameGuesses+   )+where++import GhcPrelude++import GHC.Hs as Hs+import PrelNames+import RdrName+import qualified Name+import Module+import RdrHsSyn+import OccName+import SrcLoc+import Type+import qualified Coercion ( Role(..) )+import TysWiredIn+import BasicTypes as Hs+import ForeignCall+import Unique+import ErrUtils+import Bag+import Lexeme+import Util+import FastString+import Outputable+import MonadUtils ( foldrM )++import qualified Data.ByteString as BS+import Control.Monad( unless, ap )++import Data.Maybe( catMaybes, isNothing )+import Language.Haskell.TH as TH hiding (sigP)+import Language.Haskell.TH.Syntax as TH+import Foreign.ForeignPtr+import Foreign.Ptr+import System.IO.Unsafe++-------------------------------------------------------------------+--              The external interface++convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]+convertToHsDecls origin loc ds = initCvt origin loc (fmap catMaybes (mapM cvt_dec ds))+  where+    cvt_dec d = wrapMsg "declaration" d (cvtDec d)++convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs)+convertToHsExpr origin loc e+  = initCvt origin loc $ wrapMsg "expression" e $ cvtl e++convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs)+convertToPat origin loc p+  = initCvt origin loc $ wrapMsg "pattern" p $ cvtPat p++convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs)+convertToHsType origin loc t+  = initCvt origin loc $ wrapMsg "type" t $ cvtType t++-------------------------------------------------------------------+newtype CvtM a = CvtM { unCvtM :: Origin -> SrcSpan -> Either MsgDoc (SrcSpan, a) }+    deriving (Functor)+        -- Push down the Origin (that is configurable by+        -- -fenable-th-splice-warnings) and source location;+        -- Can fail, with a single error message++-- NB: If the conversion succeeds with (Right x), there should+--     be no exception values hiding in x+-- Reason: so a (head []) in TH code doesn't subsequently+--         make GHC crash when it tries to walk the generated tree++-- Use the loc everywhere, for lack of anything better+-- In particular, we want it on binding locations, so that variables bound in+-- the spliced-in declarations get a location that at least relates to the splice point++instance Applicative CvtM where+    pure x = CvtM $ \_ loc -> Right (loc,x)+    (<*>) = ap++instance Monad CvtM where+  (CvtM m) >>= k = CvtM $ \origin loc -> case m origin loc of+    Left err -> Left err+    Right (loc',v) -> unCvtM (k v) origin loc'++initCvt :: Origin -> SrcSpan -> CvtM a -> Either MsgDoc a+initCvt origin loc (CvtM m) = fmap snd (m origin loc)++force :: a -> CvtM ()+force a = a `seq` return ()++failWith :: MsgDoc -> CvtM a+failWith m = CvtM (\_ _ -> Left m)++getOrigin :: CvtM Origin+getOrigin = CvtM (\origin loc -> Right (loc,origin))++getL :: CvtM SrcSpan+getL = CvtM (\_ loc -> Right (loc,loc))++setL :: SrcSpan -> CvtM ()+setL loc = CvtM (\_ _ -> Right (loc, ()))++returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a+returnL x = CvtM (\_ loc -> Right (loc, cL loc x))++returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)+returnJustL = fmap Just . returnL++wrapParL :: HasSrcSpan a =>+            (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess  a)+wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (cL loc x)))++wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b+-- E.g  wrapMsg "declaration" dec thing+wrapMsg what item (CvtM m)+  = CvtM $ \origin loc -> case m origin loc of+      Left err -> Left (err $$ getPprStyle msg)+      Right v  -> Right v+  where+        -- Show the item in pretty syntax normally,+        -- but with all its constructors if you say -dppr-debug+    msg sty = hang (text "When splicing a TH" <+> text what <> colon)+                 2 (if debugStyle sty+                    then text (show item)+                    else text (pprint item))++wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a+wrapL (CvtM m) = CvtM $ \origin loc -> case m origin loc of+  Left err -> Left err+  Right (loc',v) -> Right (loc',cL loc v)++-------------------------------------------------------------------+cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]+cvtDecs = fmap catMaybes . mapM cvtDec++cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs))+cvtDec (TH.ValD pat body ds)+  | TH.VarP s <- pat+  = do  { s' <- vNameL s+        ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)+        ; th_origin <- getOrigin+        ; returnJustL $ Hs.ValD noExtField $ mkFunBind th_origin s' [cl'] }++  | otherwise+  = do  { pat' <- cvtPat pat+        ; body' <- cvtGuard body+        ; ds' <- cvtLocalDecs (text "a where clause") ds+        ; returnJustL $ Hs.ValD noExtField $+          PatBind { pat_lhs = pat'+                  , pat_rhs = GRHSs noExtField body' (noLoc ds')+                  , pat_ext = noExtField+                  , pat_ticks = ([],[]) } }++cvtDec (TH.FunD nm cls)+  | null cls+  = failWith (text "Function binding for"+                 <+> quotes (text (TH.pprint nm))+                 <+> text "has no equations")+  | otherwise+  = do  { nm' <- vNameL nm+        ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls+        ; th_origin <- getOrigin+        ; returnJustL $ Hs.ValD noExtField $ mkFunBind th_origin nm' cls' }++cvtDec (TH.SigD nm typ)+  = do  { nm' <- vNameL nm+        ; ty' <- cvtType typ+        ; returnJustL $ Hs.SigD noExtField+                                    (TypeSig noExtField [nm'] (mkLHsSigWcType ty')) }++cvtDec (TH.KiSigD nm ki)+  = do  { nm' <- tconNameL nm+        ; ki' <- cvtType ki+        ; let sig' = StandaloneKindSig noExtField nm' (mkLHsSigType ki')+        ; returnJustL $ Hs.KindSigD noExtField sig' }++cvtDec (TH.InfixD fx nm)+  -- Fixity signatures are allowed for variables, constructors, and types+  -- the renamer automatically looks for types during renaming, even when+  -- the RdrName says it's a variable or a constructor. So, just assume+  -- it's a variable or constructor and proceed.+  = do { nm' <- vcNameL nm+       ; returnJustL (Hs.SigD noExtField (FixSig noExtField+                                      (FixitySig noExtField [nm'] (cvtFixity fx)))) }++cvtDec (PragmaD prag)+  = cvtPragmaD prag++cvtDec (TySynD tc tvs rhs)+  = do  { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs+        ; rhs' <- cvtType rhs+        ; returnJustL $ TyClD noExtField $+          SynDecl { tcdSExt = noExtField, tcdLName = tc', tcdTyVars = tvs'+                  , tcdFixity = Prefix+                  , tcdRhs = rhs' } }++cvtDec (DataD ctxt tc tvs ksig constrs derivs)+  = do  { let isGadtCon (GadtC    _ _ _) = True+              isGadtCon (RecGadtC _ _ _) = True+              isGadtCon (ForallC  _ _ c) = isGadtCon c+              isGadtCon _                = False+              isGadtDecl  = all isGadtCon constrs+              isH98Decl   = all (not . isGadtCon) constrs+        ; unless (isGadtDecl || isH98Decl)+                 (failWith (text "Cannot mix GADT constructors with Haskell 98"+                        <+> text "constructors"))+        ; unless (isNothing ksig || isGadtDecl)+                 (failWith (text "Kind signatures are only allowed on GADTs"))+        ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs+        ; ksig' <- cvtKind `traverse` ksig+        ; cons' <- mapM cvtConstr constrs+        ; derivs' <- cvtDerivs derivs+        ; let defn = HsDataDefn { dd_ext = noExtField+                                , dd_ND = DataType, dd_cType = Nothing+                                , dd_ctxt = ctxt'+                                , dd_kindSig = ksig'+                                , dd_cons = cons', dd_derivs = derivs' }+        ; returnJustL $ TyClD noExtField $+          DataDecl { tcdDExt = noExtField+                   , tcdLName = tc', tcdTyVars = tvs'+                   , tcdFixity = Prefix+                   , tcdDataDefn = defn } }++cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)+  = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs+        ; ksig' <- cvtKind `traverse` ksig+        ; con' <- cvtConstr constr+        ; derivs' <- cvtDerivs derivs+        ; let defn = HsDataDefn { dd_ext = noExtField+                                , dd_ND = NewType, dd_cType = Nothing+                                , dd_ctxt = ctxt'+                                , dd_kindSig = ksig'+                                , dd_cons = [con']+                                , dd_derivs = derivs' }+        ; returnJustL $ TyClD noExtField $+          DataDecl { tcdDExt = noExtField+                   , tcdLName = tc', tcdTyVars = tvs'+                   , tcdFixity = Prefix+                   , tcdDataDefn = defn } }++cvtDec (ClassD ctxt cl tvs fds decs)+  = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs+        ; fds'  <- mapM cvt_fundep fds+        ; (binds', sigs', fams', at_defs', adts') <- cvt_ci_decs (text "a class declaration") decs+        ; unless (null adts')+            (failWith $ (text "Default data instance declarations"+                     <+> text "are not allowed:")+                   $$ (Outputable.ppr adts'))+        ; returnJustL $ TyClD noExtField $+          ClassDecl { tcdCExt = noExtField+                    , tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'+                    , tcdFixity = Prefix+                    , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'+                    , tcdMeths = binds'+                    , tcdATs = fams', tcdATDefs = at_defs', tcdDocs = [] }+                              -- no docs in TH ^^+        }++cvtDec (InstanceD o ctxt ty decs)+  = do  { let doc = text "an instance declaration"+        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs+        ; unless (null fams') (failWith (mkBadDecMsg doc fams'))+        ; ctxt' <- cvtContext funPrec ctxt+        ; (dL->L loc ty') <- cvtType ty+        ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty'+        ; returnJustL $ InstD noExtField $ ClsInstD noExtField $+          ClsInstDecl { cid_ext = noExtField, cid_poly_ty = mkLHsSigType inst_ty'+                      , cid_binds = binds'+                      , cid_sigs = Hs.mkClassOpSigs sigs'+                      , cid_tyfam_insts = ats', cid_datafam_insts = adts'+                      , cid_overlap_mode = fmap (cL loc . overlap) o } }+  where+  overlap pragma =+    case pragma of+      TH.Overlaps      -> Hs.Overlaps     (SourceText "OVERLAPS")+      TH.Overlappable  -> Hs.Overlappable (SourceText "OVERLAPPABLE")+      TH.Overlapping   -> Hs.Overlapping  (SourceText "OVERLAPPING")+      TH.Incoherent    -> Hs.Incoherent   (SourceText "INCOHERENT")+++++cvtDec (ForeignD ford)+  = do { ford' <- cvtForD ford+       ; returnJustL $ ForD noExtField ford' }++cvtDec (DataFamilyD tc tvs kind)+  = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs+       ; result <- cvtMaybeKindToFamilyResultSig kind+       ; returnJustL $ TyClD noExtField $ FamDecl noExtField $+         FamilyDecl noExtField DataFamily tc' tvs' Prefix result Nothing }++cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)+  = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys+       ; ksig' <- cvtKind `traverse` ksig+       ; cons' <- mapM cvtConstr constrs+       ; derivs' <- cvtDerivs derivs+       ; let defn = HsDataDefn { dd_ext = noExtField+                               , dd_ND = DataType, dd_cType = Nothing+                               , dd_ctxt = ctxt'+                               , dd_kindSig = ksig'+                               , dd_cons = cons', dd_derivs = derivs' }++       ; returnJustL $ InstD noExtField $ DataFamInstD+           { dfid_ext = noExtField+           , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $+                           FamEqn { feqn_ext = noExtField+                                  , feqn_tycon = tc'+                                  , feqn_bndrs = bndrs'+                                  , feqn_pats = typats'+                                  , feqn_rhs = defn+                                  , feqn_fixity = Prefix } }}}++cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs)+  = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys+       ; ksig' <- cvtKind `traverse` ksig+       ; con' <- cvtConstr constr+       ; derivs' <- cvtDerivs derivs+       ; let defn = HsDataDefn { dd_ext = noExtField+                               , dd_ND = NewType, dd_cType = Nothing+                               , dd_ctxt = ctxt'+                               , dd_kindSig = ksig'+                               , dd_cons = [con'], dd_derivs = derivs' }+       ; returnJustL $ InstD noExtField $ DataFamInstD+           { dfid_ext = noExtField+           , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $+                           FamEqn { feqn_ext = noExtField+                                  , feqn_tycon = tc'+                                  , feqn_bndrs = bndrs'+                                  , feqn_pats = typats'+                                  , feqn_rhs = defn+                                  , feqn_fixity = Prefix } }}}++cvtDec (TySynInstD eqn)+  = do  { (dL->L _ eqn') <- cvtTySynEqn eqn+        ; returnJustL $ InstD noExtField $ TyFamInstD+            { tfid_ext = noExtField+            , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }++cvtDec (OpenTypeFamilyD head)+  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head+       ; returnJustL $ TyClD noExtField $ FamDecl noExtField $+         FamilyDecl noExtField OpenTypeFamily tc' tyvars' Prefix result' injectivity'+       }++cvtDec (ClosedTypeFamilyD head eqns)+  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head+       ; eqns' <- mapM cvtTySynEqn eqns+       ; returnJustL $ TyClD noExtField $ FamDecl noExtField $+         FamilyDecl noExtField (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix+                           result' injectivity' }++cvtDec (TH.RoleAnnotD tc roles)+  = do { tc' <- tconNameL tc+       ; let roles' = map (noLoc . cvtRole) roles+       ; returnJustL $ Hs.RoleAnnotD noExtField (RoleAnnotDecl noExtField tc' roles') }++cvtDec (TH.StandaloneDerivD ds cxt ty)+  = do { cxt' <- cvtContext funPrec cxt+       ; ds'  <- traverse cvtDerivStrategy ds+       ; (dL->L loc ty') <- cvtType ty+       ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty'+       ; returnJustL $ DerivD noExtField $+         DerivDecl { deriv_ext =noExtField+                   , deriv_strategy = ds'+                   , deriv_type = mkLHsSigWcType inst_ty'+                   , deriv_overlap_mode = Nothing } }++cvtDec (TH.DefaultSigD nm typ)+  = do { nm' <- vNameL nm+       ; ty' <- cvtType typ+       ; returnJustL $ Hs.SigD noExtField+                     $ ClassOpSig noExtField True [nm'] (mkLHsSigType ty')}++cvtDec (TH.PatSynD nm args dir pat)+  = do { nm'   <- cNameL nm+       ; args' <- cvtArgs args+       ; dir'  <- cvtDir nm' dir+       ; pat'  <- cvtPat pat+       ; returnJustL $ Hs.ValD noExtField $ PatSynBind noExtField $+           PSB noExtField nm' args' pat' dir' }+  where+    cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args+    cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2+    cvtArgs (TH.RecordPatSyn sels)+      = do { sels' <- mapM vNameL sels+           ; vars' <- mapM (vNameL . mkNameS . nameBase) sels+           ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' }++    cvtDir _ Unidir          = return Unidirectional+    cvtDir _ ImplBidir       = return ImplicitBidirectional+    cvtDir n (ExplBidir cls) =+      do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls+         ; th_origin <- getOrigin+         ; return $ ExplicitBidirectional $ mkMatchGroup th_origin ms }++cvtDec (TH.PatSynSigD nm ty)+  = do { nm' <- cNameL nm+       ; ty' <- cvtPatSynSigTy ty+       ; returnJustL $ Hs.SigD noExtField $ PatSynSig noExtField [nm'] (mkLHsSigType ty')}++-- Implicit parameter bindings are handled in cvtLocalDecs and+-- cvtImplicitParamBind. They are not allowed in any other scope, so+-- reaching this case indicates an error.+cvtDec (TH.ImplicitParamBindD _ _)+  = failWith (text "Implicit parameter binding only allowed in let or where")++----------------+cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)+cvtTySynEqn (TySynEqn mb_bndrs lhs rhs)+  = do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs+       ; (head_ty, args) <- split_ty_app lhs+       ; case head_ty of+           ConT nm -> do { nm' <- tconNameL nm+                         ; rhs' <- cvtType rhs+                         ; let args' = map wrap_tyarg args+                         ; returnL $ mkHsImplicitBndrs+                            $ FamEqn { feqn_ext    = noExtField+                                     , feqn_tycon  = nm'+                                     , feqn_bndrs  = mb_bndrs'+                                     , feqn_pats   = args'+                                     , feqn_fixity = Prefix+                                     , feqn_rhs    = rhs' } }+           InfixT t1 nm t2 -> do { nm' <- tconNameL nm+                                 ; args' <- mapM cvtType [t1,t2]+                                 ; rhs' <- cvtType rhs+                                 ; returnL $ mkHsImplicitBndrs+                                      $ FamEqn { feqn_ext    = noExtField+                                               , feqn_tycon  = nm'+                                               , feqn_bndrs  = mb_bndrs'+                                               , feqn_pats   =+                                                (map HsValArg args') ++ args+                                               , feqn_fixity = Hs.Infix+                                               , feqn_rhs    = rhs' } }+           _ -> failWith $ text "Invalid type family instance LHS:"+                          <+> text (show lhs)+        }++----------------+cvt_ci_decs :: MsgDoc -> [TH.Dec]+            -> CvtM (LHsBinds GhcPs,+                     [LSig GhcPs],+                     [LFamilyDecl GhcPs],+                     [LTyFamInstDecl GhcPs],+                     [LDataFamInstDecl GhcPs])+-- Convert the declarations inside a class or instance decl+-- ie signatures, bindings, and associated types+cvt_ci_decs doc decs+  = do  { decs' <- cvtDecs decs+        ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs'+        ; let (adts', no_ats')       = partitionWith is_datafam_inst bind_sig_decs'+        ; let (sigs', prob_binds')   = partitionWith is_sig no_ats'+        ; let (binds', prob_fams')   = partitionWith is_bind prob_binds'+        ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'+        ; unless (null bads) (failWith (mkBadDecMsg doc bads))+        ; return (listToBag binds', sigs', fams', ats', adts') }++----------------+cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]+             -> CvtM ( LHsContext GhcPs+                     , Located RdrName+                     , LHsQTyVars GhcPs)+cvt_tycl_hdr cxt tc tvs+  = do { cxt' <- cvtContext funPrec cxt+       ; tc'  <- tconNameL tc+       ; tvs' <- cvtTvs tvs+       ; return (cxt', tc', tvs')+       }++cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr] -> TH.Type+               -> CvtM ( LHsContext GhcPs+                       , Located RdrName+                       , Maybe [LHsTyVarBndr GhcPs]+                       , HsTyPats GhcPs)+cvt_datainst_hdr cxt bndrs tys+  = do { cxt' <- cvtContext funPrec cxt+       ; bndrs' <- traverse (mapM cvt_tv) bndrs+       ; (head_ty, args) <- split_ty_app tys+       ; case head_ty of+          ConT nm -> do { nm' <- tconNameL nm+                        ; let args' = map wrap_tyarg args+                        ; return (cxt', nm', bndrs', args') }+          InfixT t1 nm t2 -> do { nm' <- tconNameL nm+                                ; args' <- mapM cvtType [t1,t2]+                                ; return (cxt', nm', bndrs',+                                         ((map HsValArg args') ++ args)) }+          _ -> failWith $ text "Invalid type instance header:"+                          <+> text (show tys) }++----------------+cvt_tyfam_head :: TypeFamilyHead+               -> CvtM ( Located RdrName+                       , LHsQTyVars GhcPs+                       , Hs.LFamilyResultSig GhcPs+                       , Maybe (Hs.LInjectivityAnn GhcPs))++cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity)+  = do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars+       ; result' <- cvtFamilyResultSig result+       ; injectivity' <- traverse cvtInjectivityAnnotation injectivity+       ; return (tc', tyvars', result', injectivity') }++-------------------------------------------------------------------+--              Partitioning declarations+-------------------------------------------------------------------++is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)+is_fam_decl (dL->L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (cL loc d)+is_fam_decl decl = Right decl++is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)+is_tyfam_inst (dL->L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))+  = Left (cL loc d)+is_tyfam_inst decl+  = Right decl++is_datafam_inst :: LHsDecl GhcPs+                -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)+is_datafam_inst (dL->L loc (Hs.InstD  _ (DataFamInstD { dfid_inst = d })))+  = Left (cL loc d)+is_datafam_inst decl+  = Right decl++is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)+is_sig (dL->L loc (Hs.SigD _ sig)) = Left (cL loc sig)+is_sig decl                        = Right decl++is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)+is_bind (dL->L loc (Hs.ValD _ bind)) = Left (cL loc bind)+is_bind decl                         = Right decl++is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec+is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e)+is_ip_bind decl             = Right decl++mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc+mkBadDecMsg doc bads+  = sep [ text "Illegal declaration(s) in" <+> doc <> colon+        , nest 2 (vcat (map Outputable.ppr bads)) ]++---------------------------------------------------+--      Data types+---------------------------------------------------++cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)++cvtConstr (NormalC c strtys)+  = do  { c'   <- cNameL c+        ; tys' <- mapM cvt_arg strtys+        ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon tys') }++cvtConstr (RecC c varstrtys)+  = do  { c'    <- cNameL c+        ; args' <- mapM cvt_id_arg varstrtys+        ; returnL $ mkConDeclH98 c' Nothing Nothing+                                   (RecCon (noLoc args')) }++cvtConstr (InfixC st1 c st2)+  = do  { c'   <- cNameL c+        ; st1' <- cvt_arg st1+        ; st2' <- cvt_arg st2+        ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon st1' st2') }++cvtConstr (ForallC tvs ctxt con)+  = do  { tvs'      <- cvtTvs tvs+        ; ctxt'     <- cvtContext funPrec ctxt+        ; (dL->L _ con')  <- cvtConstr con+        ; returnL $ add_forall tvs' ctxt' con' }+  where+    add_cxt lcxt         Nothing           = Just lcxt+    add_cxt (dL->L loc cxt1) (Just (dL->L _ cxt2))+      = Just (cL loc (cxt1 ++ cxt2))++    add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })+      = con { con_forall = noLoc $ not (null all_tvs)+            , con_qvars  = mkHsQTvs all_tvs+            , con_mb_cxt = add_cxt cxt' cxt }+      where+        all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars++    add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt })+      = con { con_forall = noLoc $ not (null all_tvs)+            , con_ex_tvs = all_tvs+            , con_mb_cxt = add_cxt cxt' cxt }+      where+        all_tvs = hsQTvExplicit tvs' ++ ex_tvs++    add_forall _ _ (XConDecl nec) = noExtCon nec++cvtConstr (GadtC [] _strtys _ty)+  = failWith (text "GadtC must have at least one constructor name")++cvtConstr (GadtC c strtys ty)+  = do  { c'      <- mapM cNameL c+        ; args    <- mapM cvt_arg strtys+        ; (dL->L _ ty') <- cvtType ty+        ; c_ty    <- mk_arr_apps args ty'+        ; returnL $ fst $ mkGadtDecl c' c_ty}++cvtConstr (RecGadtC [] _varstrtys _ty)+  = failWith (text "RecGadtC must have at least one constructor name")++cvtConstr (RecGadtC c varstrtys ty)+  = do  { c'       <- mapM cNameL c+        ; ty'      <- cvtType ty+        ; rec_flds <- mapM cvt_id_arg varstrtys+        ; let rec_ty = noLoc (HsFunTy noExtField+                                           (noLoc $ HsRecTy noExtField rec_flds) ty')+        ; returnL $ fst $ mkGadtDecl c' rec_ty }++cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness+cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack+cvtSrcUnpackedness SourceNoUnpack       = SrcNoUnpack+cvtSrcUnpackedness SourceUnpack         = SrcUnpack++cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness+cvtSrcStrictness NoSourceStrictness = NoSrcStrict+cvtSrcStrictness SourceLazy         = SrcLazy+cvtSrcStrictness SourceStrict       = SrcStrict++cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs)+cvt_arg (Bang su ss, ty)+  = do { ty'' <- cvtType ty+       ; let ty' = parenthesizeHsType appPrec ty''+             su' = cvtSrcUnpackedness su+             ss' = cvtSrcStrictness ss+       ; returnL $ HsBangTy noExtField (HsSrcBang NoSourceText su' ss') ty' }++cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)+cvt_id_arg (i, str, ty)+  = do  { (dL->L li i') <- vNameL i+        ; ty' <- cvt_arg (str,ty)+        ; return $ noLoc (ConDeclField+                          { cd_fld_ext = noExtField+                          , cd_fld_names+                              = [cL li $ FieldOcc noExtField (cL li i')]+                          , cd_fld_type =  ty'+                          , cd_fld_doc = Nothing}) }++cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)+cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs+                  ; returnL cs' }++cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs)+cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs+                               ; ys' <- mapM tNameL ys+                               ; returnL (xs', ys') }+++------------------------------------------+--      Foreign declarations+------------------------------------------++cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)+cvtForD (ImportF callconv safety from nm ty)+  -- the prim and javascript calling conventions do not support headers+  -- and are inserted verbatim, analogous to mkImport in RdrHsSyn+  | callconv == TH.Prim || callconv == TH.JavaScript+  = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing+                    (CFunction (StaticTarget (SourceText from)+                                             (mkFastString from) Nothing+                                             True))+                    (noLoc $ quotedSourceText from))+  | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')+                                 (mkFastString (TH.nameBase nm))+                                 from (noLoc $ quotedSourceText from)+  = mk_imp impspec+  | otherwise+  = failWith $ text (show from) <+> text "is not a valid ccall impent"+  where+    mk_imp impspec+      = do { nm' <- vNameL nm+           ; ty' <- cvtType ty+           ; return (ForeignImport { fd_i_ext = noExtField+                                   , fd_name = nm'+                                   , fd_sig_ty = mkLHsSigType ty'+                                   , fd_fi = impspec })+           }+    safety' = case safety of+                     Unsafe     -> PlayRisky+                     Safe       -> PlaySafe+                     Interruptible -> PlayInterruptible++cvtForD (ExportF callconv as nm ty)+  = do  { nm' <- vNameL nm+        ; ty' <- cvtType ty+        ; let e = CExport (noLoc (CExportStatic (SourceText as)+                                                (mkFastString as)+                                                (cvt_conv callconv)))+                                                (noLoc (SourceText as))+        ; return $ ForeignExport { fd_e_ext = noExtField+                                 , fd_name = nm'+                                 , fd_sig_ty = mkLHsSigType ty'+                                 , fd_fe = e } }++cvt_conv :: TH.Callconv -> CCallConv+cvt_conv TH.CCall      = CCallConv+cvt_conv TH.StdCall    = StdCallConv+cvt_conv TH.CApi       = CApiConv+cvt_conv TH.Prim       = PrimCallConv+cvt_conv TH.JavaScript = JavaScriptCallConv++------------------------------------------+--              Pragmas+------------------------------------------++cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))+cvtPragmaD (InlineP nm inline rm phases)+  = do { nm' <- vNameL nm+       ; let dflt = dfltActivation inline+       ; let src TH.NoInline  = "{-# NOINLINE"+             src TH.Inline    = "{-# INLINE"+             src TH.Inlinable = "{-# INLINABLE"+       ; let ip   = InlinePragma { inl_src    = SourceText $ src inline+                                 , inl_inline = cvtInline inline+                                 , inl_rule   = cvtRuleMatch rm+                                 , inl_act    = cvtPhases phases dflt+                                 , inl_sat    = Nothing }+       ; returnJustL $ Hs.SigD noExtField $ InlineSig noExtField nm' ip }++cvtPragmaD (SpecialiseP nm ty inline phases)+  = do { nm' <- vNameL nm+       ; ty' <- cvtType ty+       ; let src TH.NoInline  = "{-# SPECIALISE NOINLINE"+             src TH.Inline    = "{-# SPECIALISE INLINE"+             src TH.Inlinable = "{-# SPECIALISE INLINE"+       ; let (inline', dflt,srcText) = case inline of+               Just inline1 -> (cvtInline inline1, dfltActivation inline1,+                                src inline1)+               Nothing      -> (NoUserInline,   AlwaysActive,+                                "{-# SPECIALISE")+       ; let ip = InlinePragma { inl_src    = SourceText srcText+                               , inl_inline = inline'+                               , inl_rule   = Hs.FunLike+                               , inl_act    = cvtPhases phases dflt+                               , inl_sat    = Nothing }+       ; returnJustL $ Hs.SigD noExtField $ SpecSig noExtField nm' [mkLHsSigType ty'] ip }++cvtPragmaD (SpecialiseInstP ty)+  = do { ty' <- cvtType ty+       ; returnJustL $ Hs.SigD noExtField $+         SpecInstSig noExtField (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }++cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)+  = do { let nm' = mkFastString nm+       ; let act = cvtPhases phases AlwaysActive+       ; ty_bndrs' <- traverse (mapM cvt_tv) ty_bndrs+       ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs+       ; lhs'   <- cvtl lhs+       ; rhs'   <- cvtl rhs+       ; returnJustL $ Hs.RuleD noExtField+            $ HsRules { rds_ext = noExtField+                      , rds_src = SourceText "{-# RULES"+                      , rds_rules = [noLoc $+                          HsRule { rd_ext  = noExtField+                                 , rd_name = (noLoc (quotedSourceText nm,nm'))+                                 , rd_act  = act+                                 , rd_tyvs = ty_bndrs'+                                 , rd_tmvs = tm_bndrs'+                                 , rd_lhs  = lhs'+                                 , rd_rhs  = rhs' }] }++          }++cvtPragmaD (AnnP target exp)+  = do { exp' <- cvtl exp+       ; target' <- case target of+         ModuleAnnotation  -> return ModuleAnnProvenance+         TypeAnnotation n  -> do+           n' <- tconName n+           return (TypeAnnProvenance  (noLoc n'))+         ValueAnnotation n -> do+           n' <- vcName n+           return (ValueAnnProvenance (noLoc n'))+       ; returnJustL $ Hs.AnnD noExtField+                     $ HsAnnotation noExtField (SourceText "{-# ANN") target' exp'+       }++cvtPragmaD (LineP line file)+  = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))+       ; return Nothing+       }+cvtPragmaD (CompleteP cls mty)+  = do { cls' <- noLoc <$> mapM cNameL cls+       ; mty'  <- traverse tconNameL mty+       ; returnJustL $ Hs.SigD noExtField+                   $ CompleteMatchSig noExtField NoSourceText cls' mty' }++dfltActivation :: TH.Inline -> Activation+dfltActivation TH.NoInline = NeverActive+dfltActivation _           = AlwaysActive++cvtInline :: TH.Inline -> Hs.InlineSpec+cvtInline TH.NoInline  = Hs.NoInline+cvtInline TH.Inline    = Hs.Inline+cvtInline TH.Inlinable = Hs.Inlinable++cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo+cvtRuleMatch TH.ConLike = Hs.ConLike+cvtRuleMatch TH.FunLike = Hs.FunLike++cvtPhases :: TH.Phases -> Activation -> Activation+cvtPhases AllPhases       dflt = dflt+cvtPhases (FromPhase i)   _    = ActiveAfter NoSourceText i+cvtPhases (BeforePhase i) _    = ActiveBefore NoSourceText i++cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs)+cvtRuleBndr (RuleVar n)+  = do { n' <- vNameL n+       ; return $ noLoc $ Hs.RuleBndr noExtField n' }+cvtRuleBndr (TypedRuleVar n ty)+  = do { n'  <- vNameL n+       ; ty' <- cvtType ty+       ; return $ noLoc $ Hs.RuleBndrSig noExtField n' $ mkLHsSigWcType ty' }++---------------------------------------------------+--              Declarations+---------------------------------------------------++cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)+cvtLocalDecs doc ds+  = case partitionWith is_ip_bind ds of+      ([], []) -> return (EmptyLocalBinds noExtField)+      ([], _) -> do+        ds' <- cvtDecs ds+        let (binds, prob_sigs) = partitionWith is_bind ds'+        let (sigs, bads) = partitionWith is_sig prob_sigs+        unless (null bads) (failWith (mkBadDecMsg doc bads))+        return (HsValBinds noExtField (ValBinds noExtField (listToBag binds) sigs))+      (ip_binds, []) -> do+        binds <- mapM (uncurry cvtImplicitParamBind) ip_binds+        return (HsIPBinds noExtField (IPBinds noExtField binds))+      ((_:_), (_:_)) ->+        failWith (text "Implicit parameters mixed with other bindings")++cvtClause :: HsMatchContext RdrName+          -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))+cvtClause ctxt (Clause ps body wheres)+  = do  { ps' <- cvtPats ps+        ; let pps = map (parenthesizePat appPrec) ps'+        ; g'  <- cvtGuard body+        ; ds' <- cvtLocalDecs (text "a where clause") wheres+        ; returnL $ Hs.Match noExtField ctxt pps (GRHSs noExtField g' (noLoc ds')) }++cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)+cvtImplicitParamBind n e = do+    n' <- wrapL (ipName n)+    e' <- cvtl e+    returnL (IPBind noExtField (Left n') e')++-------------------------------------------------------------------+--              Expressions+-------------------------------------------------------------------++cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)+cvtl e = wrapL (cvt e)+  where+    cvt (VarE s)        = do { s' <- vName s; return $ HsVar noExtField (noLoc s') }+    cvt (ConE s)        = do { s' <- cName s; return $ HsVar noExtField (noLoc s') }+    cvt (LitE l)+      | overloadedLit l = go cvtOverLit (HsOverLit noExtField)+                             (hsOverLitNeedsParens appPrec)+      | otherwise       = go cvtLit (HsLit noExtField)+                             (hsLitNeedsParens appPrec)+      where+        go :: (Lit -> CvtM (l GhcPs))+           -> (l GhcPs -> HsExpr GhcPs)+           -> (l GhcPs -> Bool)+           -> CvtM (HsExpr GhcPs)+        go cvt_lit mk_expr is_compound_lit = do+          l' <- cvt_lit l+          let e' = mk_expr l'+          return $ if is_compound_lit l' then HsPar noExtField (noLoc e') else e'+    cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y+                                   ; return $ HsApp noExtField (mkLHsPar x')+                                                          (mkLHsPar y')}+    cvt (AppE x y)            = do { x' <- cvtl x; y' <- cvtl y+                                   ; return $ HsApp noExtField (mkLHsPar x')+                                                          (mkLHsPar y')}+    cvt (AppTypeE e t) = do { e' <- cvtl e+                            ; t' <- cvtType t+                            ; let tp = parenthesizeHsType appPrec t'+                            ; return $ HsAppType noExtField e'+                                     $ mkHsWildCardBndrs tp }+    cvt (LamE [] e)    = cvt e -- Degenerate case. We convert the body as its+                               -- own expression to avoid pretty-printing+                               -- oddities that can result from zero-argument+                               -- lambda expressions. See #13856.+    cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e+                            ; let pats = map (parenthesizePat appPrec) ps'+                            ; th_origin <- getOrigin+                            ; return $ HsLam noExtField (mkMatchGroup th_origin+                                             [mkSimpleMatch LambdaExpr+                                             pats e'])}+    cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch CaseAlt) ms+                            ; th_origin <- getOrigin+                            ; return $ HsLamCase noExtField+                                                   (mkMatchGroup th_origin ms')+                            }+    cvt (TupE es)        = cvt_tup es Boxed+    cvt (UnboxedTupE es) = cvt_tup es Unboxed+    cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e+                                       ; unboxedSumChecks alt arity+                                       ; return $ ExplicitSum noExtField+                                                                   alt arity e'}+    cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;+                            ; return $ HsIf noExtField (Just noSyntaxExpr) x' y' z' }+    cvt (MultiIfE alts)+      | null alts      = failWith (text "Multi-way if-expression with no alternatives")+      | otherwise      = do { alts' <- mapM cvtpair alts+                            ; return $ HsMultiIf noExtField alts' }+    cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (text "a let expression") ds+                            ; e' <- cvtl e; return $ HsLet noExtField (noLoc ds') e'}+    cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms+                            ; th_origin <- getOrigin+                            ; return $ HsCase noExtField e'+                                                 (mkMatchGroup th_origin ms') }+    cvt (DoE ss)       = cvtHsDo DoExpr ss+    cvt (MDoE ss)      = cvtHsDo MDoExpr ss+    cvt (CompE ss)     = cvtHsDo ListComp ss+    cvt (ArithSeqE dd) = do { dd' <- cvtDD dd+                            ; return $ ArithSeq noExtField Nothing dd' }+    cvt (ListE xs)+      | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s)+                                          ; return (HsLit noExtField l') }+             -- Note [Converting strings]+      | otherwise       = do { xs' <- mapM cvtl xs+                             ; return $ ExplicitList noExtField Nothing xs'+                             }++    -- Infix expressions+    cvt (InfixE (Just x) s (Just y)) = ensureValidOpExp s $+      do { x' <- cvtl x+         ; s' <- cvtl s+         ; y' <- cvtl y+         ; let px = parenthesizeHsExpr opPrec x'+               py = parenthesizeHsExpr opPrec y'+         ; wrapParL (HsPar noExtField)+           $ OpApp noExtField px s' py }+           -- Parenthesise both arguments and result,+           -- to ensure this operator application does+           -- does not get re-associated+           -- See Note [Operator association]+    cvt (InfixE Nothing  s (Just y)) = ensureValidOpExp s $+                                       do { s' <- cvtl s; y' <- cvtl y+                                          ; wrapParL (HsPar noExtField) $+                                                          SectionR noExtField s' y' }+                                            -- See Note [Sections in HsSyn] in GHC.Hs.Expr+    cvt (InfixE (Just x) s Nothing ) = ensureValidOpExp s $+                                       do { x' <- cvtl x; s' <- cvtl s+                                          ; wrapParL (HsPar noExtField) $+                                                          SectionL noExtField x' s' }++    cvt (InfixE Nothing  s Nothing ) = ensureValidOpExp s $+                                       do { s' <- cvtl s+                                          ; return $ HsPar noExtField s' }+                                       -- Can I indicate this is an infix thing?+                                       -- Note [Dropping constructors]++    cvt (UInfixE x s y)  = ensureValidOpExp s $+                           do { x' <- cvtl x+                              ; let x'' = case unLoc x' of+                                            OpApp {} -> x'+                                            _ -> mkLHsPar x'+                              ; cvtOpApp x'' s y } --  Note [Converting UInfix]++    cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar noExtField e' }+    cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t+                              ; let pe = parenthesizeHsExpr sigPrec e'+                              ; return $ ExprWithTySig noExtField pe (mkLHsSigWcType t') }+    cvt (RecConE c flds) = do { c' <- cNameL c+                              ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds+                              ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }+    cvt (RecUpdE e flds) = do { e' <- cvtl e+                              ; flds'+                                  <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))+                                           flds+                              ; return $ mkRdrRecordUpd e' flds' }+    cvt (StaticE e)      = fmap (HsStatic noExtField) $ cvtl e+    cvt (UnboundVarE s)  = do -- Use of 'vcName' here instead of 'vName' is+                              -- important, because UnboundVarE may contain+                              -- constructor names - see #14627.+                              { s' <- vcName s+                              ; return $ HsVar noExtField (noLoc s') }+    cvt (LabelE s)       = do { return $ HsOverLabel noExtField Nothing (fsLit s) }+    cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExtField n' }++{- | #16895 Ensure an infix expression's operator is a variable/constructor.+Consider this example:++  $(uInfixE [|1|] [|id id|] [|2|])++This infix expression is obviously ill-formed so we use this helper function+to reject such programs outright.++The constructors `ensureValidOpExp` permits should be in sync with `pprInfixExp`+in Language.Haskell.TH.Ppr from the template-haskell library.+-}+ensureValidOpExp :: TH.Exp -> CvtM a -> CvtM a+ensureValidOpExp (VarE _n) m = m+ensureValidOpExp (ConE _n) m = m+ensureValidOpExp (UnboundVarE _n) m = m+ensureValidOpExp _e _m =+    failWith (text "Non-variable expression is not allowed in an infix expression")++{- Note [Dropping constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we drop constructors from the input, we must insert parentheses around the+argument. For example:++  UInfixE x * (AppE (InfixE (Just y) + Nothing) z)++If we convert the InfixE expression to an operator section but don't insert+parentheses, the above expression would be reassociated to++  OpApp (OpApp x * y) + z++which we don't want.+-}++cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp)+       -> CvtM (LHsRecField' t (LHsExpr GhcPs))+cvtFld f (v,e)+  = do  { v' <- vNameL v; e' <- cvtl e+        ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v'+                                     , hsRecFieldArg = e'+                                     , hsRecPun      = False}) }++cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs)+cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }+cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }+cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }+cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }++cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs)+cvt_tup es boxity = do { let cvtl_maybe Nothing  = return missingTupArg+                             cvtl_maybe (Just e) = fmap (Present noExtField) (cvtl e)+                       ; es' <- mapM cvtl_maybe es+                       ; return $ ExplicitTuple+                                    noExtField+                                    (map noLoc es')+                                    boxity }++{- Note [Operator assocation]+We must be quite careful about adding parens:+  * Infix (UInfix ...) op arg      Needs parens round the first arg+  * Infix (Infix ...) op arg       Needs parens round the first arg+  * UInfix (UInfix ...) op arg     No parens for first arg+  * UInfix (Infix ...) op arg      Needs parens round first arg+++Note [Converting UInfix]+~~~~~~~~~~~~~~~~~~~~~~~~+When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust+the trees to reflect the fixities of the underlying operators:++  UInfixE x * (UInfixE y + z) ---> (x * y) + z++This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and+@mkHsOpTyRn@ in RnTypes), which expects that the input will be completely+right-biased for types and left-biased for everything else. So we left-bias the+trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@.++Sample input:++  UInfixE+   (UInfixE x op1 y)+   op2+   (UInfixE z op3 w)++Sample output:++  OpApp+    (OpApp+      (OpApp x op1 y)+      op2+      z)+    op3+    w++The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this+biasing.+-}++{- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.+The produced tree of infix expressions will be left-biased, provided @x@ is.++We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis+is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that+this holds for both branches (of @cvtOpApp@), provided we assume it holds for+the recursive calls to @cvtOpApp@.++When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased+since we have already run @cvtl@ on it.+-}+cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs)+cvtOpApp x op1 (UInfixE y op2 z)+  = do { l <- wrapL $ cvtOpApp x op1 y+       ; cvtOpApp l op2 z }+cvtOpApp x op y+  = do { op' <- cvtl op+       ; y' <- cvtl y+       ; return (OpApp noExtField x op' y') }++-------------------------------------+--      Do notation and statements+-------------------------------------++cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr GhcPs)+cvtHsDo do_or_lc stmts+  | null stmts = failWith (text "Empty stmt list in do-block")+  | otherwise+  = do  { stmts' <- cvtStmts stmts+        ; let Just (stmts'', last') = snocView stmts'++        ; last'' <- case last' of+                    (dL->L loc (BodyStmt _ body _ _))+                      -> return (cL loc (mkLastStmt body))+                    _ -> failWith (bad_last last')++        ; return $ HsDo noExtField do_or_lc (noLoc (stmts'' ++ [last''])) }+  where+    bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon+                         , nest 2 $ Outputable.ppr stmt+                         , text "(It should be an expression.)" ]++cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)]+cvtStmts = mapM cvtStmt++cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs))+cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkBodyStmt e' }+cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }+cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (text "a let binding") ds+                            ; returnL $ LetStmt noExtField (noLoc ds') }+cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss+                            ; returnL $ ParStmt noExtField dss' noExpr noSyntaxExpr }+  where+    cvt_one ds = do { ds' <- cvtStmts ds+                    ; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) }+cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnL (mkRecStmt ss') }++cvtMatch :: HsMatchContext RdrName+         -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))+cvtMatch ctxt (TH.Match p body decs)+  = do  { p' <- cvtPat p+        ; let lp = case p' of+                     (dL->L loc SigPat{}) -> cL loc (ParPat noExtField p') -- #14875+                     _                    -> p'+        ; g' <- cvtGuard body+        ; decs' <- cvtLocalDecs (text "a where clause") decs+        ; returnL $ Hs.Match noExtField ctxt [lp] (GRHSs noExtField g' (noLoc decs')) }++cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]+cvtGuard (GuardedB pairs) = mapM cvtpair pairs+cvtGuard (NormalB e)      = do { e' <- cvtl e+                               ; g' <- returnL $ GRHS noExtField [] e'; return [g'] }++cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))+cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs+                              ; g' <- returnL $ mkBodyStmt ge'+                              ; returnL $ GRHS noExtField [g'] rhs' }+cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs+                              ; returnL $ GRHS noExtField gs' rhs' }++cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs)+cvtOverLit (IntegerL i)+  = do { force i; return $ mkHsIntegral   (mkIntegralLit i) }+cvtOverLit (RationalL r)+  = do { force r; return $ mkHsFractional (mkFractionalLit r) }+cvtOverLit (StringL s)+  = do { let { s' = mkFastString s }+       ; force s'+       ; return $ mkHsIsString (quotedSourceText s) s'+       }+cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"+-- An Integer is like an (overloaded) '3' in a Haskell source program+-- Similarly 3.5 for fractionals++{- Note [Converting strings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to+a string literal for "xy".  Of course, we might hope to get+(LitE (StringL "xy")), but not always, and allCharLs fails quickly+if it isn't a literal string+-}++allCharLs :: [TH.Exp] -> Maybe String+-- Note [Converting strings]+-- NB: only fire up this setup for a non-empty list, else+--     there's a danger of returning "" for [] :: [Int]!+allCharLs xs+  = case xs of+      LitE (CharL c) : ys -> go [c] ys+      _                   -> Nothing+  where+    go cs []                    = Just (reverse cs)+    go cs (LitE (CharL c) : ys) = go (c:cs) ys+    go _  _                     = Nothing++cvtLit :: Lit -> CvtM (HsLit GhcPs)+cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim NoSourceText i }+cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim NoSourceText w }+cvtLit (FloatPrimL f)+  = do { force f; return $ HsFloatPrim noExtField (mkFractionalLit f) }+cvtLit (DoublePrimL f)+  = do { force f; return $ HsDoublePrim noExtField (mkFractionalLit f) }+cvtLit (CharL c)       = do { force c; return $ HsChar NoSourceText c }+cvtLit (CharPrimL c)   = do { force c; return $ HsCharPrim NoSourceText c }+cvtLit (StringL s)     = do { let { s' = mkFastString s }+                            ; force s'+                            ; return $ HsString (quotedSourceText s) s' }+cvtLit (StringPrimL s) = do { let { s' = BS.pack s }+                            ; force s'+                            ; return $ HsStringPrim NoSourceText s' }+cvtLit (BytesPrimL (Bytes fptr off sz)) = do+  let bs = unsafePerformIO $ withForeignPtr fptr $ \ptr ->+             BS.packCStringLen (ptr `plusPtr` fromIntegral off, fromIntegral sz)+  force bs+  return $ HsStringPrim NoSourceText bs+cvtLit _ = panic "Convert.cvtLit: Unexpected literal"+        -- cvtLit should not be called on IntegerL, RationalL+        -- That precondition is established right here in+        -- Convert.hs, hence panic++quotedSourceText :: String -> SourceText+quotedSourceText s = SourceText $ "\"" ++ s ++ "\""++cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs]+cvtPats pats = mapM cvtPat pats++cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs)+cvtPat pat = wrapL (cvtp pat)++cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs)+cvtp (TH.LitP l)+  | overloadedLit l    = do { l' <- cvtOverLit l+                            ; return (mkNPat (noLoc l') Nothing) }+                                  -- Not right for negative patterns;+                                  -- need to think about that!+  | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat noExtField l' }+cvtp (TH.VarP s)       = do { s' <- vName s+                            ; return $ Hs.VarPat noExtField (noLoc s') }+cvtp (TupP ps)         = do { ps' <- cvtPats ps+                            ; return $ TuplePat noExtField ps' Boxed }+cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps+                            ; return $ TuplePat noExtField ps' Unboxed }+cvtp (UnboxedSumP p alt arity)+                       = do { p' <- cvtPat p+                            ; unboxedSumChecks alt arity+                            ; return $ SumPat noExtField p' alt arity }+cvtp (ConP s ps)       = do { s' <- cNameL s; ps' <- cvtPats ps+                            ; let pps = map (parenthesizePat appPrec) ps'+                            ; return $ ConPatIn s' (PrefixCon pps) }+cvtp (InfixP p1 s p2)  = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2+                            ; wrapParL (ParPat noExtField) $+                              ConPatIn s' $+                              InfixCon (parenthesizePat opPrec p1')+                                       (parenthesizePat opPrec p2') }+                            -- See Note [Operator association]+cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]+cvtp (ParensP p)       = do { p' <- cvtPat p;+                            ; case unLoc p' of  -- may be wrapped ConPatIn+                                ParPat {} -> return $ unLoc p'+                                _         -> return $ ParPat noExtField p' }+cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat noExtField p' }+cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat noExtField p' }+cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p+                            ; return $ AsPat noExtField s' p' }+cvtp TH.WildP          = return $ WildPat noExtField+cvtp (RecP c fs)       = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs+                            ; return $ ConPatIn c'+                                     $ Hs.RecCon (HsRecFields fs' Nothing) }+cvtp (ListP ps)        = do { ps' <- cvtPats ps+                            ; return+                                   $ ListPat noExtField ps'}+cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t+                            ; return $ SigPat noExtField p' (mkLHsSigWcType t') }+cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p+                            ; return $ ViewPat noExtField e' p'}++cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))+cvtPatFld (s,p)+  = do  { (dL->L ls s') <- vNameL s+        ; p' <- cvtPat p+        ; return (noLoc $ HsRecField { hsRecFieldLbl+                                         = cL ls $ mkFieldOcc (cL ls s')+                                     , hsRecFieldArg = p'+                                     , hsRecPun      = False}) }++{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.+The produced tree of infix patterns will be left-biased, provided @x@ is.++See the @cvtOpApp@ documentation for how this function works.+-}+cvtOpAppP :: Hs.LPat GhcPs -> TH.Name -> TH.Pat -> CvtM (Hs.Pat GhcPs)+cvtOpAppP x op1 (UInfixP y op2 z)+  = do { l <- wrapL $ cvtOpAppP x op1 y+       ; cvtOpAppP l op2 z }+cvtOpAppP x op y+  = do { op' <- cNameL op+       ; y' <- cvtPat y+       ; return (ConPatIn op' (InfixCon x y')) }++-----------------------------------------------------------+--      Types and type variables++cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars GhcPs)+cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }++cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs)+cvt_tv (TH.PlainTV nm)+  = do { nm' <- tNameL nm+       ; returnL $ UserTyVar noExtField nm' }+cvt_tv (TH.KindedTV nm ki)+  = do { nm' <- tNameL nm+       ; ki' <- cvtKind ki+       ; returnL $ KindedTyVar noExtField nm' ki' }++cvtRole :: TH.Role -> Maybe Coercion.Role+cvtRole TH.NominalR          = Just Coercion.Nominal+cvtRole TH.RepresentationalR = Just Coercion.Representational+cvtRole TH.PhantomR          = Just Coercion.Phantom+cvtRole TH.InferR            = Nothing++cvtContext :: PprPrec -> TH.Cxt -> CvtM (LHsContext GhcPs)+cvtContext p tys = do { preds' <- mapM cvtPred tys+                      ; parenthesizeHsContext p <$> returnL preds' }++cvtPred :: TH.Pred -> CvtM (LHsType GhcPs)+cvtPred = cvtType++cvtDerivClause :: TH.DerivClause+               -> CvtM (LHsDerivingClause GhcPs)+cvtDerivClause (TH.DerivClause ds ctxt)+  = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext appPrec ctxt+       ; ds'   <- traverse cvtDerivStrategy ds+       ; returnL $ HsDerivingClause noExtField ds' ctxt' }++cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)+cvtDerivStrategy TH.StockStrategy    = returnL Hs.StockStrategy+cvtDerivStrategy TH.AnyclassStrategy = returnL Hs.AnyclassStrategy+cvtDerivStrategy TH.NewtypeStrategy  = returnL Hs.NewtypeStrategy+cvtDerivStrategy (TH.ViaStrategy ty) = do+  ty' <- cvtType ty+  returnL $ Hs.ViaStrategy (mkLHsSigType ty')++cvtType :: TH.Type -> CvtM (LHsType GhcPs)+cvtType = cvtTypeKind "type"++cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs)+cvtTypeKind ty_str ty+  = do { (head_ty, tys') <- split_ty_app ty+       ; let m_normals = mapM extract_normal tys'+                                where extract_normal (HsValArg ty) = Just ty+                                      extract_normal _ = Nothing++       ; case head_ty of+           TupleT n+            | Just normals <- m_normals+            , normals `lengthIs` n         -- Saturated+            -> returnL (HsTupleTy noExtField HsBoxedOrConstraintTuple normals)+            | otherwise+            -> mk_apps+               (HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n))))+               tys'+           UnboxedTupleT n+             | Just normals <- m_normals+             , normals `lengthIs` n               -- Saturated+             -> returnL (HsTupleTy noExtField HsUnboxedTuple normals)+             | otherwise+             -> mk_apps+                (HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Unboxed n))))+                tys'+           UnboxedSumT n+             | n < 2+            -> failWith $+                   vcat [ text "Illegal sum arity:" <+> text (show n)+                        , nest 2 $+                            text "Sums must have an arity of at least 2" ]+             | Just normals <- m_normals+             , normals `lengthIs` n -- Saturated+             -> returnL (HsSumTy noExtField normals)+             | otherwise+             -> mk_apps+                (HsTyVar noExtField NotPromoted (noLoc (getRdrName (sumTyCon n))))+                tys'+           ArrowT+             | Just normals <- m_normals+             , [x',y'] <- normals -> do+                 x'' <- case unLoc x' of+                          HsFunTy{}    -> returnL (HsParTy noExtField x')+                          HsForAllTy{} -> returnL (HsParTy noExtField x') -- #14646+                          HsQualTy{}   -> returnL (HsParTy noExtField x') -- #15324+                          _            -> return $+                                          parenthesizeHsType sigPrec x'+                 let y'' = parenthesizeHsType sigPrec y'+                 returnL (HsFunTy noExtField x'' y'')+             | otherwise+             -> mk_apps+                (HsTyVar noExtField NotPromoted (noLoc (getRdrName funTyCon)))+                tys'+           ListT+             | Just normals <- m_normals+             , [x'] <- normals -> do+                returnL (HsListTy noExtField x')+             | otherwise+             -> mk_apps+                (HsTyVar noExtField NotPromoted (noLoc (getRdrName listTyCon)))+                tys'++           VarT nm -> do { nm' <- tNameL nm+                         ; mk_apps (HsTyVar noExtField NotPromoted nm') tys' }+           ConT nm -> do { nm' <- tconName nm+                         ; let prom = name_promotedness nm'+                         ; mk_apps (HsTyVar noExtField prom (noLoc nm')) tys'}++           ForallT tvs cxt ty+             | null tys'+             -> do { tvs' <- cvtTvs tvs+                   ; cxt' <- cvtContext funPrec cxt+                   ; ty'  <- cvtType ty+                   ; loc <- getL+                   ; let hs_ty  = mkHsForAllTy tvs loc ForallInvis tvs' rho_ty+                         rho_ty = mkHsQualTy cxt loc cxt' ty'++                   ; return hs_ty }++           ForallVisT tvs ty+             | null tys'+             -> do { tvs' <- cvtTvs tvs+                   ; ty'  <- cvtType ty+                   ; loc  <- getL+                   ; pure $ mkHsForAllTy tvs loc ForallVis tvs' ty' }++           SigT ty ki+             -> do { ty' <- cvtType ty+                   ; ki' <- cvtKind ki+                   ; mk_apps (HsKindSig noExtField ty' ki') tys'+                   }++           LitT lit+             -> mk_apps (HsTyLit noExtField (cvtTyLit lit)) tys'++           WildCardT+             -> mk_apps mkAnonWildCardTy tys'++           InfixT t1 s t2+             -> do { s'  <- tconName s+                   ; t1' <- cvtType t1+                   ; t2' <- cvtType t2+                   ; let prom = name_promotedness s'+                   ; mk_apps+                      (HsTyVar noExtField prom (noLoc s'))+                      ([HsValArg t1', HsValArg t2'] ++ tys')+                   }++           UInfixT t1 s t2+             -> do { t2' <- cvtType t2+                   ; t <- cvtOpAppT t1 s t2'+                   ; mk_apps (unLoc t) tys'+                   } -- Note [Converting UInfix]++           ParensT t+             -> do { t' <- cvtType t+                   ; mk_apps (HsParTy noExtField t') tys'+                   }++           PromotedT nm -> do { nm' <- cName nm+                              ; mk_apps (HsTyVar noExtField IsPromoted (noLoc nm'))+                                        tys' }+                 -- Promoted data constructor; hence cName++           PromotedTupleT n+              | Just normals <- m_normals+              , normals `lengthIs` n   -- Saturated+              -> returnL (HsExplicitTupleTy noExtField normals)+              | otherwise+              -> mk_apps+                 (HsTyVar noExtField IsPromoted (noLoc (getRdrName (tupleDataCon Boxed n))))+                 tys'++           PromotedNilT+             -> mk_apps (HsExplicitListTy noExtField IsPromoted []) tys'++           PromotedConsT  -- See Note [Representing concrete syntax in types]+                          -- in Language.Haskell.TH.Syntax+              | Just normals <- m_normals+              , [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- normals+              -> do+                  returnL (HsExplicitListTy noExtField ip (ty1:tys2))+              | otherwise+              -> mk_apps+                 (HsTyVar noExtField IsPromoted (noLoc (getRdrName consDataCon)))+                 tys'++           StarT+             -> mk_apps+                (HsTyVar noExtField NotPromoted (noLoc (getRdrName liftedTypeKindTyCon)))+                tys'++           ConstraintT+             -> mk_apps+                (HsTyVar noExtField NotPromoted (noLoc (getRdrName constraintKindTyCon)))+                tys'++           EqualityT+             | Just normals <- m_normals+             , [x',y'] <- normals ->+                   let px = parenthesizeHsType opPrec x'+                       py = parenthesizeHsType opPrec y'+                   in returnL (HsOpTy noExtField px (noLoc eqTyCon_RDR) py)+               -- The long-term goal is to remove the above case entirely and+               -- subsume it under the case for InfixT. See #15815, comment:6,+               -- for more details.++             | otherwise ->+                   mk_apps (HsTyVar noExtField NotPromoted+                            (noLoc eqTyCon_RDR)) tys'+           ImplicitParamT n t+             -> do { n' <- wrapL $ ipName n+                   ; t' <- cvtType t+                   ; returnL (HsIParamTy noExtField n' t')+                   }++           _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))+    }++-- ConT/InfixT can contain both data constructor (i.e., promoted) names and+-- other (i.e, unpromoted) names, as opposed to PromotedT, which can only+-- contain data constructor names. See #15572/#17394. We use this function to+-- determine whether to mark a name as promoted/unpromoted when dealing with+-- ConT/InfixT.+name_promotedness :: RdrName -> Hs.PromotionFlag+name_promotedness nm+  | isRdrDataCon nm = IsPromoted+  | otherwise       = NotPromoted++-- | Constructs an application of a type to arguments passed in a list.+mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)+mk_apps head_ty type_args = do+  head_ty' <- returnL head_ty+  -- We must parenthesize the function type in case of an explicit+  -- signature. For instance, in `(Maybe :: Type -> Type) Int`, there+  -- _must_ be parentheses around `Maybe :: Type -> Type`.+  let phead_ty :: LHsType GhcPs+      phead_ty = parenthesizeHsType sigPrec head_ty'++      go :: [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)+      go [] = pure head_ty'+      go (arg:args) =+        case arg of+          HsValArg ty  -> do p_ty <- add_parens ty+                             mk_apps (HsAppTy noExtField phead_ty p_ty) args+          HsTypeArg l ki -> do p_ki <- add_parens ki+                               mk_apps (HsAppKindTy l phead_ty p_ki) args+          HsArgPar _   -> mk_apps (HsParTy noExtField phead_ty) args++  go type_args+   where+    -- See Note [Adding parens for splices]+    add_parens lt@(dL->L _ t)+      | hsTypeNeedsParens appPrec t = returnL (HsParTy noExtField lt)+      | otherwise                   = return lt++wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs+wrap_tyarg (HsValArg ty)    = HsValArg  $ parenthesizeHsType appPrec ty+wrap_tyarg (HsTypeArg l ki) = HsTypeArg l $ parenthesizeHsType appPrec ki+wrap_tyarg ta@(HsArgPar {}) = ta -- Already parenthesized++-- ---------------------------------------------------------------------+-- Note [Adding parens for splices]+{-+The hsSyn representation of parsed source explicitly contains all the original+parens, as written in the source.++When a Template Haskell (TH) splice is evaluated, the original splice is first+renamed and type checked and then finally converted to core in DsMeta. This core+is then run in the TH engine, and the result comes back as a TH AST.++In the process, all parens are stripped out, as they are not needed.++This Convert module then converts the TH AST back to hsSyn AST.++In order to pretty-print this hsSyn AST, parens need to be adde back at certain+points so that the code is readable with its original meaning.++So scattered through Convert.hs are various points where parens are added.++See (among other closed issued) https://gitlab.haskell.org/ghc/ghc/issues/14289+-}+-- ---------------------------------------------------------------------++-- | Constructs an arrow type with a specified return type+mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs)+mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL+    where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs)+          go arg ret_ty = do { ret_ty_l <- returnL ret_ty+                             ; return (HsFunTy noExtField arg ret_ty_l) }++split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs])+split_ty_app ty = go ty []+  where+    go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg a':as') }+    go (AppKindT ty ki) as' = do { ki' <- cvtKind ki+                                 ; go ty (HsTypeArg noSrcSpan ki':as') }+    go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') }+    go f as           = return (f,as)++cvtTyLit :: TH.TyLit -> HsTyLit+cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i+cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)++{- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator+application @x `op` y@. The produced tree of infix types will be right-biased,+provided @y@ is.++See the @cvtOpApp@ documentation for how this function works.+-}+cvtOpAppT :: TH.Type -> TH.Name -> LHsType GhcPs -> CvtM (LHsType GhcPs)+cvtOpAppT (UInfixT x op2 y) op1 z+  = do { l <- cvtOpAppT y op1 z+       ; cvtOpAppT x op2 l }+cvtOpAppT x op y+  = do { op' <- tconNameL op+       ; x' <- cvtType x+       ; returnL (mkHsOpTy x' op' y) }++cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)+cvtKind = cvtTypeKind "kind"++-- | Convert Maybe Kind to a type family result signature. Used with data+-- families where naming of the result is not possible (thus only kind or no+-- signature is possible).+cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind+                              -> CvtM (LFamilyResultSig GhcPs)+cvtMaybeKindToFamilyResultSig Nothing   = returnL (Hs.NoSig noExtField)+cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki+                                             ; returnL (Hs.KindSig noExtField ki') }++-- | Convert type family result signature. Used with both open and closed type+-- families.+cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs)+cvtFamilyResultSig TH.NoSig           = returnL (Hs.NoSig noExtField)+cvtFamilyResultSig (TH.KindSig ki)    = do { ki' <- cvtKind ki+                                           ; returnL (Hs.KindSig noExtField  ki') }+cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr+                                           ; returnL (Hs.TyVarSig noExtField tv) }++-- | Convert injectivity annotation of a type family.+cvtInjectivityAnnotation :: TH.InjectivityAnn+                         -> CvtM (Hs.LInjectivityAnn GhcPs)+cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)+  = do { annLHS' <- tNameL annLHS+       ; annRHS' <- mapM tNameL annRHS+       ; returnL (Hs.InjectivityAnn annLHS' annRHS') }++cvtPatSynSigTy :: TH.Type -> CvtM (LHsType GhcPs)+-- pattern synonym types are of peculiar shapes, which is why we treat+-- them separately from regular types;+-- see Note [Pattern synonym type signatures and Template Haskell]+cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))+  | null exis, null provs = cvtType (ForallT univs reqs ty)+  | null univs, null reqs = do { l   <- getL+                               ; ty' <- cvtType (ForallT exis provs ty)+                               ; return $ cL l (HsQualTy { hst_ctxt = cL l []+                                                         , hst_xqual = noExtField+                                                         , hst_body = ty' }) }+  | null reqs             = do { l      <- getL+                               ; univs' <- hsQTvExplicit <$> cvtTvs univs+                               ; ty'    <- cvtType (ForallT exis provs ty)+                               ; let forTy = HsForAllTy+                                              { hst_fvf = ForallInvis+                                              , hst_bndrs = univs'+                                              , hst_xforall = noExtField+                                              , hst_body = cL l cxtTy }+                                     cxtTy = HsQualTy { hst_ctxt = cL l []+                                                      , hst_xqual = noExtField+                                                      , hst_body = ty' }+                               ; return $ cL l forTy }+  | otherwise             = cvtType (ForallT univs reqs (ForallT exis provs ty))+cvtPatSynSigTy ty         = cvtType ty++-----------------------------------------------------------+cvtFixity :: TH.Fixity -> Hs.Fixity+cvtFixity (TH.Fixity prec dir) = Hs.Fixity NoSourceText prec (cvt_dir dir)+   where+     cvt_dir TH.InfixL = Hs.InfixL+     cvt_dir TH.InfixR = Hs.InfixR+     cvt_dir TH.InfixN = Hs.InfixN++-----------------------------------------------------------+++-----------------------------------------------------------+-- some useful things++overloadedLit :: Lit -> Bool+-- True for literals that Haskell treats as overloaded+overloadedLit (IntegerL  _) = True+overloadedLit (RationalL _) = True+overloadedLit _             = False++-- Checks that are performed when converting unboxed sum expressions and+-- patterns alike.+unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM ()+unboxedSumChecks alt arity+    | alt > arity+    = failWith $ text "Sum alternative"    <+> text (show alt)+             <+> text "exceeds its arity," <+> text (show arity)+    | alt <= 0+    = failWith $ vcat [ text "Illegal sum alternative:" <+> text (show alt)+                      , nest 2 $ text "Sum alternatives must start from 1" ]+    | arity < 2+    = failWith $ vcat [ text "Illegal sum arity:" <+> text (show arity)+                      , nest 2 $ text "Sums must have an arity of at least 2" ]+    | otherwise+    = return ()++-- | If passed an empty list of 'TH.TyVarBndr's, this simply returns the+-- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy'+-- using the provided 'LHsQTyVars' and 'LHsType'.+mkHsForAllTy :: [TH.TyVarBndr]+             -- ^ The original Template Haskell type variable binders+             -> SrcSpan+             -- ^ The location of the returned 'LHsType' if it needs an+             --   explicit forall+             -> ForallVisFlag+             -- ^ Whether this is @forall@ is visible (e.g., @forall a ->@)+             --   or invisible (e.g., @forall a.@)+             -> LHsQTyVars GhcPs+             -- ^ The converted type variable binders+             -> LHsType GhcPs+             -- ^ The converted rho type+             -> LHsType GhcPs+             -- ^ The complete type, quantified with a forall if necessary+mkHsForAllTy tvs loc fvf tvs' rho_ty+  | null tvs  = rho_ty+  | otherwise = cL loc $ HsForAllTy { hst_fvf = fvf+                                    , hst_bndrs = hsQTvExplicit tvs'+                                    , hst_xforall = noExtField+                                    , hst_body = rho_ty }++-- | If passed an empty 'TH.Cxt', this simply returns the third argument+-- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided+-- 'LHsContext' and 'LHsType'.++-- It's important that we don't build an HsQualTy if the context is empty,+-- as the pretty-printer for HsType _always_ prints contexts, even if+-- they're empty. See #13183.+mkHsQualTy :: TH.Cxt+           -- ^ The original Template Haskell context+           -> SrcSpan+           -- ^ The location of the returned 'LHsType' if it needs an+           --   explicit context+           -> LHsContext GhcPs+           -- ^ The converted context+           -> LHsType GhcPs+           -- ^ The converted tau type+           -> LHsType GhcPs+           -- ^ The complete type, qualified with a context if necessary+mkHsQualTy ctxt loc ctxt' ty+  | null ctxt = ty+  | otherwise = cL loc $ HsQualTy { hst_xqual = noExtField+                                  , hst_ctxt  = ctxt'+                                  , hst_body  = ty }++--------------------------------------------------------------------+--      Turning Name back into RdrName+--------------------------------------------------------------------++-- variable names+vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)+vName,  cName,  vcName,  tName,  tconName  :: TH.Name -> CvtM RdrName++-- Variable names+vNameL n = wrapL (vName n)+vName n = cvtName OccName.varName n++-- Constructor function names; this is Haskell source, hence srcDataName+cNameL n = wrapL (cName n)+cName n = cvtName OccName.dataName n++-- Variable *or* constructor names; check by looking at the first char+vcNameL n = wrapL (vcName n)+vcName n = if isVarName n then vName n else cName n++-- Type variable names+tNameL n = wrapL (tName n)+tName n = cvtName OccName.tvName n++-- Type Constructor names+tconNameL n = wrapL (tconName n)+tconName n = cvtName OccName.tcClsName n++ipName :: String -> CvtM HsIPName+ipName n+  = do { unless (okVarOcc n) (failWith (badOcc OccName.varName n))+       ; return (HsIPName (fsLit n)) }++cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName+cvtName ctxt_ns (TH.Name occ flavour)+  | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)+  | otherwise+  = do { loc <- getL+       ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour+       ; force rdr_name+       ; return rdr_name }+  where+    occ_str = TH.occString occ++okOcc :: OccName.NameSpace -> String -> Bool+okOcc ns str+  | OccName.isVarNameSpace ns     = okVarOcc str+  | OccName.isDataConNameSpace ns = okConOcc str+  | otherwise                     = okTcOcc  str++-- Determine the name space of a name in a type+--+isVarName :: TH.Name -> Bool+isVarName (TH.Name occ _)+  = case TH.occString occ of+      ""    -> False+      (c:_) -> startsVarId c || startsVarSym c++badOcc :: OccName.NameSpace -> String -> SDoc+badOcc ctxt_ns occ+  = text "Illegal" <+> pprNameSpace ctxt_ns+        <+> text "name:" <+> quotes (text occ)++thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName+-- This turns a TH Name into a RdrName; used for both binders and occurrences+-- See Note [Binders in Template Haskell]+-- The passed-in name space tells what the context is expecting;+--      use it unless the TH name knows what name-space it comes+--      from, in which case use the latter+--+-- We pass in a SrcSpan (gotten from the monad) because this function+-- is used for *binders* and if we make an Exact Name we want it+-- to have a binding site inside it.  (cf #5434)+--+-- ToDo: we may generate silly RdrNames, by passing a name space+--       that doesn't match the string, like VarName ":+",+--       which will give confusing error messages later+--+-- The strict applications ensure that any buried exceptions get forced+thRdrName loc ctxt_ns th_occ th_name+  = case th_name of+     TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod+     TH.NameQ mod  -> (mkRdrQual  $! mk_mod mod) $! occ+     TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq (fromInteger uniq)) $! occ) loc)+     TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq (fromInteger uniq)) $! occ) loc)+     TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name+              | otherwise                           -> mkRdrUnqual $! occ+              -- We check for built-in syntax here, because the TH+              -- user might have written a (NameS "(,,)"), for example+  where+    occ :: OccName.OccName+    occ = mk_occ ctxt_ns th_occ++-- Return an unqualified exact RdrName if we're dealing with built-in syntax.+-- See #13776.+thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName+thOrigRdrName occ th_ns pkg mod =+  let occ' = mk_occ (mk_ghc_ns th_ns) occ+  in case isBuiltInOcc_maybe occ' of+       Just name -> nameRdrName name+       Nothing   -> (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! occ'++thRdrNameGuesses :: TH.Name -> [RdrName]+thRdrNameGuesses (TH.Name occ flavour)+  -- This special case for NameG ensures that we don't generate duplicates in the output list+  | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod]+  | otherwise                         = [ thRdrName noSrcSpan gns occ_str flavour+                                        | gns <- guessed_nss]+  where+    -- guessed_ns are the name spaces guessed from looking at the TH name+    guessed_nss+      | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]+      | otherwise                       = [OccName.varName, OccName.tvName]+    occ_str = TH.occString occ++-- The packing and unpacking is rather turgid :-(+mk_occ :: OccName.NameSpace -> String -> OccName.OccName+mk_occ ns occ = OccName.mkOccName ns occ++mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace+mk_ghc_ns TH.DataName  = OccName.dataName+mk_ghc_ns TH.TcClsName = OccName.tcClsName+mk_ghc_ns TH.VarName   = OccName.varName++mk_mod :: TH.ModName -> ModuleName+mk_mod mod = mkModuleName (TH.modString mod)++mk_pkg :: TH.PkgName -> UnitId+mk_pkg pkg = stringToUnitId (TH.pkgString pkg)++mk_uniq :: Int -> Unique+mk_uniq u = mkUniqueGrimily u++{-+Note [Binders in Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this TH term construction:+  do { x1 <- TH.newName "x"   -- newName :: String -> Q TH.Name+     ; x2 <- TH.newName "x"   -- Builds a NameU+     ; x3 <- TH.newName "x"++     ; let x = mkName "x"     -- mkName :: String -> TH.Name+                              -- Builds a NameS++     ; return (LamE (..pattern [x1,x2]..) $+               LamE (VarPat x3) $+               ..tuple (x1,x2,x3,x)) }++It represents the term   \[x1,x2]. \x3. (x1,x2,x3,x)++a) We don't want to complain about "x" being bound twice in+   the pattern [x1,x2]+b) We don't want x3 to shadow the x1,x2+c) We *do* want 'x' (dynamically bound with mkName) to bind+   to the innermost binding of "x", namely x3.+d) When pretty printing, we want to print a unique with x1,x2+   etc, else they'll all print as "x" which isn't very helpful++When we convert all this to HsSyn, the TH.Names are converted with+thRdrName.  To achieve (b) we want the binders to be Exact RdrNames.+Achieving (a) is a bit awkward, because+   - We must check for duplicate and shadowed names on Names,+     not RdrNames, *after* renaming.+     See Note [Collect binders only after renaming] in GHC.Hs.Utils++   - But to achieve (a) we must distinguish between the Exact+     RdrNames arising from TH and the Unqual RdrNames that would+     come from a user writing \[x,x] -> blah++So in Convert.thRdrName we translate+   TH Name                          RdrName+   --------------------------------------------------------+   NameU (arising from newName) --> Exact (Name{ System })+   NameS (arising from mkName)  --> Unqual++Notice that the NameUs generate *System* Names.  Then, when+figuring out shadowing and duplicates, we can filter out+System Names.++This use of System Names fits with other uses of System Names, eg for+temporary variables "a". Since there are lots of things called "a" we+usually want to print the name with the unique, and that is indeed+the way System Names are printed.++There's a small complication of course; see Note [Looking up Exact+RdrNames] in RnEnv.+-}++{-+Note [Pattern synonym type signatures and Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In general, the type signature of a pattern synonym++  pattern P x1 x2 .. xn = <some-pattern>++is of the form++   forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t++with the following parts:++   1) the (possibly empty lists of) universally quantified type+      variables `univs` and required constraints `reqs` on them.+   2) the (possibly empty lists of) existentially quantified type+      variables `exis` and the provided constraints `provs` on them.+   3) the types `t1`, `t2`, .., `tn` of the pattern synonym's arguments x1,+      x2, .., xn, respectively+   4) the type `t` of <some-pattern>, mentioning only universals from `univs`.++Due to the two forall quantifiers and constraint contexts (either of+which might be empty), pattern synonym type signatures are treated+specially in `deSugar/DsMeta.hs`, `hsSyn/Convert.hs`, and+`typecheck/TcSplice.hs`:++   (a) When desugaring a pattern synonym from HsSyn to TH.Dec in+       `deSugar/DsMeta.hs`, we represent its *full* type signature in TH, i.e.:++           ForallT univs reqs (ForallT exis provs ty)+              (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)++   (b) When converting pattern synonyms from TH.Dec to HsSyn in+       `hsSyn/Convert.hs`, we convert their TH type signatures back to an+       appropriate Haskell pattern synonym type of the form++         forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t++       where initial empty `univs` type variables or an empty `reqs`+       constraint context are represented *explicitly* as `() =>`.++   (c) When reifying a pattern synonym in `typecheck/TcSplice.hs`, we always+       return its *full* type, i.e.:++           ForallT univs reqs (ForallT exis provs ty)+              (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)++The key point is to always represent a pattern synonym's *full* type+in cases (a) and (c) to make it clear which of the two forall+quantifiers and/or constraint contexts are specified, and which are+not. See GHC's user's guide on pattern synonyms for more information+about pattern synonym type signatures.++-}
− compiler/GhclibHsVersions.h 
@@ -1,65 +0,0 @@-#pragma once--#if 0--IMPORTANT!  If you put extra tabs/spaces in these macro definitions,-you will screw up the layout where they are used in case expressions!--(This is cpp-dependent, of course)--#endif--/* Useful in the headers that we share with the RTS */-#define COMPILING_GHC 1--/* Pull in all the platform defines for this build (foo_TARGET_ARCH etc.) */-#include "ghc_boot_platform.h"--/* Pull in the autoconf defines (HAVE_FOO), but don't include- * ghcconfig.h, because that will include ghcplatform.h which has the- * wrong platform settings for the compiler (it has the platform- * settings for the target plat instead). */-#include "ghcautoconf.h"--#define GLOBAL_VAR(name,value,ty)  \-{-# NOINLINE name #-};             \-name :: IORef (ty);                \-name = Util.global (value);--#define GLOBAL_VAR_M(name,value,ty) \-{-# NOINLINE name #-};              \-name :: IORef (ty);                 \-name = Util.globalM (value);---#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \-{-# NOINLINE name #-};                                      \-name :: IORef (ty);                                         \-name = Util.sharedGlobal (value) (accessor);                \-foreign import ccall unsafe saccessor                       \-  accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));--#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty)  \-{-# NOINLINE name #-};                                         \-name :: IORef (ty);                                            \-name = Util.sharedGlobalM (value) (accessor);                  \-foreign import ccall unsafe saccessor                          \-  accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));---#define ASSERT(e)      if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else-#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else-#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $---- Examples:   Assuming   flagSet :: String -> m Bool------    do { c   <- getChar; MASSERT( isUpper c ); ... }---    do { c   <- getChar; MASSERT2( isUpper c, text "Bad" ); ... }---    do { str <- getStr;  ASSERTM( flagSet str ); .. }---    do { str <- getStr;  ASSERTM2( flagSet str, text "Bad" ); .. }---    do { str <- getStr;  WARNM2( flagSet str, text "Flag is set" ); .. }-#define MASSERT(e)      ASSERT(e) return ()-#define MASSERT2(e,msg) ASSERT2(e,msg) return ()-#define ASSERTM(e)      do { bool <- e; MASSERT(bool) }-#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) }-#define WARNM2(e,msg)   do { bool <- e; WARN(bool, msg) return () }
+ compiler/HsVersions.h view
@@ -0,0 +1,56 @@+#pragma once++-- For GHC_STAGE+#include "ghcplatform.h"++#if 0++IMPORTANT!  If you put extra tabs/spaces in these macro definitions,+you will screw up the layout where they are used in case expressions!++(This is cpp-dependent, of course)++#endif++#define GLOBAL_VAR(name,value,ty)  \+{-# NOINLINE name #-};             \+name :: IORef (ty);                \+name = Util.global (value);++#define GLOBAL_VAR_M(name,value,ty) \+{-# NOINLINE name #-};              \+name :: IORef (ty);                 \+name = Util.globalM (value);+++#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \+{-# NOINLINE name #-};                                      \+name :: IORef (ty);                                         \+name = Util.sharedGlobal (value) (accessor);                \+foreign import ccall unsafe saccessor                       \+  accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));++#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty)  \+{-# NOINLINE name #-};                                         \+name :: IORef (ty);                                            \+name = Util.sharedGlobalM (value) (accessor);                  \+foreign import ccall unsafe saccessor                          \+  accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));+++#define ASSERT(e)      if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else+#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else+#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $++-- Examples:   Assuming   flagSet :: String -> m Bool+--+--    do { c   <- getChar; MASSERT( isUpper c ); ... }+--    do { c   <- getChar; MASSERT2( isUpper c, text "Bad" ); ... }+--    do { str <- getStr;  ASSERTM( flagSet str ); .. }+--    do { str <- getStr;  ASSERTM2( flagSet str, text "Bad" ); .. }+--    do { str <- getStr;  WARNM2( flagSet str, text "Flag is set" ); .. }+#define MASSERT(e)      ASSERT(e) return ()+#define MASSERT2(e,msg) ASSERT2(e,msg) return ()+#define ASSERTM(e)      do { bool <- e; MASSERT(bool) }+#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) }+#define WARNM2(e,msg)   do { bool <- e; WARN(bool, msg) return () }
compiler/backpack/DriverBkp.hs view
@@ -16,7 +16,7 @@  module DriverBkp (doBackpack) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -54,7 +54,7 @@ import qualified GHC.LanguageExtensions as LangExt  import Panic-import Data.List+import Data.List ( partition ) import System.Exit import Control.Monad import System.FilePath@@ -82,8 +82,7 @@     buf <- liftIO $ hGetStringBuffer src_filename     let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great     case unP parseBackpack (mkPState dflags buf loc) of-        PFailed _ span err -> do-            liftIO $ throwOneError (mkPlainErrMsg dflags span err)+        PFailed pst -> throwErrors (getErrorMessages pst dflags)         POk _ pkgname_bkp -> do             -- OK, so we have an LHsUnit PackageName, but we want an             -- LHsUnit HsComponentId.  So let's rename it.@@ -107,8 +106,9 @@   where     cid = hsComponentId (unLoc (hsunitName unit))     reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit)))-    get_reqs (DeclD SignatureD (L _ modname) _) = unitUniqDSet modname-    get_reqs (DeclD ModuleD _ _) = emptyUniqDSet+    get_reqs (DeclD HsigFile (L _ modname) _) = unitUniqDSet modname+    get_reqs (DeclD HsSrcFile _ _) = emptyUniqDSet+    get_reqs (DeclD HsBootFile _ _) = emptyUniqDSet     get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) =         unitIdFreeHoles (convertHsUnitId hsuid) @@ -643,10 +643,7 @@      --  1. Create a HsSrcFile/HsigFile summary for every     --  explicitly mentioned module/signature.-    let get_decl (L _ (DeclD dt lmodname mb_hsmod)) = do-          let hsc_src = case dt of-                          ModuleD    -> HsSrcFile-                          SignatureD -> HsigFile+    let get_decl (L _ (DeclD hsc_src lmodname mb_hsmod)) = do           Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod         get_decl _ = return Nothing     nodes <- catMaybes `fmap` mapM get_decl decls
compiler/backpack/NameShape.hs view
@@ -10,7 +10,7 @@     maybeSubstNameShape,     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude
compiler/backpack/RnModIface.hs view
@@ -13,7 +13,7 @@     tcRnModExports,     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -721,10 +721,8 @@ rnIfaceType (IfaceAppTy t1 t2)     = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceAppArgs t2 rnIfaceType (IfaceLitTy l)         = return (IfaceLitTy l)-rnIfaceType (IfaceFunTy t1 t2)-    = IfaceFunTy <$> rnIfaceType t1 <*> rnIfaceType t2-rnIfaceType (IfaceDFunTy t1 t2)-    = IfaceDFunTy <$> rnIfaceType t1 <*> rnIfaceType t2+rnIfaceType (IfaceFunTy af t1 t2)+    = IfaceFunTy af <$> rnIfaceType t1 <*> rnIfaceType t2 rnIfaceType (IfaceTupleTy s i tks)     = IfaceTupleTy s i <$> rnIfaceAppArgs tks rnIfaceType (IfaceTyConApp tc tks)
compiler/cmm/CLabel.hs view
@@ -39,8 +39,8 @@         mkAsmTempEndLabel,         mkAsmTempDieLabel, -        mkSplitMarkerLabel,         mkDirty_MUT_VAR_Label,+        mkNonmovingWriteBarrierEnabledLabel,         mkUpdInfoLabel,         mkBHUpdInfoLabel,         mkIndStaticInfoLabel,@@ -99,7 +99,7 @@         needsCDecl, maybeLocalBlockLabel, externallyVisibleCLabel,         isMathFun,         isCFunctionLabel, isGcPtrLabel, labelDynamic,-        isLocalCLabel,+        isLocalCLabel, mayRedirectTo,          -- * Conversions         toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, hasHaskellName,@@ -109,7 +109,7 @@         isConInfoTableLabel     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -121,12 +121,11 @@ import Name import Unique import PrimOp-import Config import CostCentre import Outputable import FastString import DynFlags-import Platform+import GHC.Platform import UniqSet import Util import PprCore ( {- instances -} )@@ -486,7 +485,9 @@                                -- See Note [Proc-point local block entry-point].  -- Constructing Cmm Labels-mkDirty_MUT_VAR_Label, mkSplitMarkerLabel, mkUpdInfoLabel,+mkDirty_MUT_VAR_Label,+    mkNonmovingWriteBarrierEnabledLabel,+    mkUpdInfoLabel,     mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,     mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel,     mkMAP_DIRTY_infoLabel,@@ -496,7 +497,8 @@     mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel,     mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel :: CLabel mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction-mkSplitMarkerLabel              = CmmLabel rtsUnitId (fsLit "__stg_split_marker")    CmmCode+mkNonmovingWriteBarrierEnabledLabel+                                = CmmLabel rtsUnitId (fsLit "nonmoving_write_barrier_enabled") CmmData mkUpdInfoLabel                  = CmmLabel rtsUnitId (fsLit "stg_upd_frame")         CmmInfo mkBHUpdInfoLabel                = CmmLabel rtsUnitId (fsLit "stg_bh_upd_frame" )     CmmInfo mkIndStaticInfoLabel            = CmmLabel rtsUnitId (fsLit "stg_IND_STATIC")        CmmInfo@@ -582,8 +584,7 @@         -> FunctionOrData         -> CLabel -mkForeignLabel str mb_sz src fod-    = ForeignLabel str mb_sz src  fod+mkForeignLabel = ForeignLabel   -- | Update the label size field in a ForeignLabel@@ -762,7 +763,7 @@ -- ----------------------------------------------------------------------------- -- Does a CLabel need declaring before use or not? ----- See wiki:Commentary/Compiler/Backends/PprC#Prototypes+-- See wiki:commentary/compiler/backends/ppr-c#prototypes  needsCDecl :: CLabel -> Bool   -- False <=> it's pre-declared; don't bother@@ -1153,35 +1154,35 @@ -}  instance Outputable CLabel where-  ppr c = sdocWithPlatform $ \platform -> pprCLabel platform c+  ppr c = sdocWithDynFlags $ \dynFlags -> pprCLabel dynFlags c -pprCLabel :: Platform -> CLabel -> SDoc+pprCLabel :: DynFlags -> CLabel -> SDoc  pprCLabel _ (LocalBlockLabel u)   =  tempLabelPrefixOrUnderscore <> pprUniqueAlways u -pprCLabel platform (AsmTempLabel u)- | not (platformUnregisterised platform)+pprCLabel dynFlags (AsmTempLabel u)+ | not (platformUnregisterised $ targetPlatform dynFlags)   =  tempLabelPrefixOrUnderscore <> pprUniqueAlways u -pprCLabel platform (AsmTempDerivedLabel l suf)- | cGhcWithNativeCodeGen == "YES"-   = ptext (asmTempLabelPrefix platform)+pprCLabel dynFlags (AsmTempDerivedLabel l suf)+ | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags+   = ptext (asmTempLabelPrefix $ targetPlatform dynFlags)      <> case l of AsmTempLabel u    -> pprUniqueAlways u                   LocalBlockLabel u -> pprUniqueAlways u-                  _other            -> pprCLabel platform l+                  _other            -> pprCLabel dynFlags l      <> ftext suf -pprCLabel platform (DynamicLinkerLabel info lbl)- | cGhcWithNativeCodeGen == "YES"-   = pprDynamicLinkerAsmLabel platform info lbl+pprCLabel dynFlags (DynamicLinkerLabel info lbl)+ | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags+   = pprDynamicLinkerAsmLabel (targetPlatform dynFlags) info lbl -pprCLabel _ PicBaseLabel- | cGhcWithNativeCodeGen == "YES"+pprCLabel dynFlags PicBaseLabel+ | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags    = text "1b" -pprCLabel platform (DeadStripPreventer lbl)- | cGhcWithNativeCodeGen == "YES"+pprCLabel dynFlags (DeadStripPreventer lbl)+ | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags    =    {-       `lbl` can be temp one but we need to ensure that dsp label will stay@@ -1189,23 +1190,24 @@       optional `_` (underscore) because this is how you mark non-temp symbols       on some platforms (Darwin)    -}-   maybe_underscore $ text "dsp_"-   <> pprCLabel platform lbl <> text "_dsp"+   maybe_underscore dynFlags $ text "dsp_"+   <> pprCLabel dynFlags lbl <> text "_dsp" -pprCLabel _ (StringLitLabel u)- | cGhcWithNativeCodeGen == "YES"+pprCLabel dynFlags (StringLitLabel u)+ | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags   = pprUniqueAlways u <> ptext (sLit "_str") -pprCLabel platform lbl+pprCLabel dynFlags lbl    = getPprStyle $ \ sty ->-     if cGhcWithNativeCodeGen == "YES" && asmStyle sty-     then maybe_underscore (pprAsmCLbl platform lbl)+     if platformMisc_ghcWithNativeCodeGen (platformMisc dynFlags) && asmStyle sty+     then maybe_underscore dynFlags $ pprAsmCLbl (targetPlatform dynFlags) lbl      else pprCLbl lbl -maybe_underscore :: SDoc -> SDoc-maybe_underscore doc-  | underscorePrefix = pp_cSEP <> doc-  | otherwise        = doc+maybe_underscore :: DynFlags -> SDoc -> SDoc+maybe_underscore dynFlags doc =+  if platformMisc_leadingUnderscore $ platformMisc dynFlags+  then pp_cSEP <> doc+  else doc  pprAsmCLbl :: Platform -> CLabel -> SDoc pprAsmCLbl platform (ForeignLabel fs (Just sz) _ _)@@ -1365,9 +1367,6 @@ -- ----------------------------------------------------------------------------- -- Machine-dependent knowledge about labels. -underscorePrefix :: Bool   -- leading underscore on assembler labels?-underscorePrefix = (cLeadingUnderscore == "YES")- asmTempLabelPrefix :: Platform -> PtrString  -- for formatting labels asmTempLabelPrefix platform = case platformOS platform of     OSDarwin -> sLit "L"@@ -1434,3 +1433,139 @@           SymbolPtr       -> text ".LC_" <> ppr lbl           GotSymbolPtr    -> ppr lbl <> text "@got"           GotSymbolOffset -> ppr lbl <> text "@gotoff"++-- Figure out whether `symbol` may serve as an alias+-- to `target` within one compilation unit.+--+-- This is true if any of these holds:+-- * `target` is a module-internal haskell name.+-- * `target` is an exported name, but comes from the same+--   module as `symbol`+--+-- These are sufficient conditions for establishing e.g. a+-- GNU assembly alias ('.equiv' directive). Sadly, there is+-- no such thing as an alias to an imported symbol (conf.+-- http://blog.omega-prime.co.uk/2011/07/06/the-sad-state-of-symbol-aliases/)+-- See note [emit-time elimination of static indirections].+--+-- Precondition is that both labels represent the+-- same semantic value.++mayRedirectTo :: CLabel -> CLabel -> Bool+mayRedirectTo symbol target+ | Just nam <- haskellName+ , staticClosureLabel+ , isExternalName nam+ , Just mod <- nameModule_maybe nam+ , Just anam <- hasHaskellName symbol+ , Just amod <- nameModule_maybe anam+ = amod == mod++ | Just nam <- haskellName+ , staticClosureLabel+ , isInternalName nam+ = True++ | otherwise = False+   where staticClosureLabel = isStaticClosureLabel target+         haskellName = hasHaskellName target+++{-+Note [emit-time elimination of static indirections]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As described in #15155, certain static values are repesentationally+equivalent, e.g. 'cast'ed values (when created by 'newtype' wrappers).++             newtype A = A Int+             {-# NOINLINE a #-}+             a = A 42++a1_rYB :: Int+[GblId, Caf=NoCafRefs, Unf=OtherCon []]+a1_rYB = GHC.Types.I# 42#++a [InlPrag=NOINLINE] :: A+[GblId, Unf=OtherCon []]+a = a1_rYB `cast` (Sym (T15155.N:A[0]) :: Int ~R# A)++Formerly we created static indirections for these (IND_STATIC), which+consist of a statically allocated forwarding closure that contains+the (possibly tagged) indirectee. (See CMM/assembly below.)+This approach is suboptimal for two reasons:+  (a) they occupy extra space,+  (b) they need to be entered in order to obtain the indirectee,+      thus they cannot be tagged.++Fortunately there is a common case where static indirections can be+eliminated while emitting assembly (native or LLVM), viz. when the+indirectee is in the same module (object file) as the symbol that+points to it. In this case an assembly-level identification can+be created ('.equiv' directive), and as such the same object will+be assigned two names in the symbol table. Any of the identified+symbols can be referenced by a tagged pointer.++Currently the 'mayRedirectTo' predicate will+give a clue whether a label can be equated with another, already+emitted, label (which can in turn be an alias). The general mechanics+is that we identify data (IND_STATIC closures) that are amenable+to aliasing while pretty-printing of assembly output, and emit the+'.equiv' directive instead of static data in such a case.++Here is a sketch how the output is massaged:++                     Consider+newtype A = A Int+{-# NOINLINE a #-}+a = A 42                                -- I# 42# is the indirectee+                                        -- 'a' is exported++                 results in STG++a1_rXq :: GHC.Types.Int+[GblId, Caf=NoCafRefs, Unf=OtherCon []] =+    CCS_DONT_CARE GHC.Types.I#! [42#];++T15155.a [InlPrag=NOINLINE] :: T15155.A+[GblId, Unf=OtherCon []] =+    CAF_ccs  \ u  []  a1_rXq;++                 and CMM++[section ""data" . a1_rXq_closure" {+     a1_rXq_closure:+         const GHC.Types.I#_con_info;+         const 42;+ }]++[section ""data" . T15155.a_closure" {+     T15155.a_closure:+         const stg_IND_STATIC_info;+         const a1_rXq_closure+1;+         const 0;+         const 0;+ }]++The emitted assembly is++#### INDIRECTEE+a1_rXq_closure:                         -- module local haskell value+        .quad   GHC.Types.I#_con_info   -- an Int+        .quad   42++#### BEFORE+.globl T15155.a_closure                 -- exported newtype wrapped value+T15155.a_closure:+        .quad   stg_IND_STATIC_info     -- the closure info+        .quad   a1_rXq_closure+1        -- indirectee ('+1' being the tag)+        .quad   0+        .quad   0++#### AFTER+.globl T15155.a_closure                 -- exported newtype wrapped value+.equiv a1_rXq_closure,T15155.a_closure  -- both are shared++The transformation is performed because+     T15155.a_closure `mayRedirectTo` a1_rXq_closure+1+returns True.+-}
compiler/cmm/Cmm.hs view
@@ -39,8 +39,7 @@ import Hoopl.Graph import Hoopl.Label import Outputable--import Data.Word        ( Word8 )+import Data.ByteString (ByteString)  ----------------------------------------------------------------------------- --  Cmm, GenCmm@@ -110,6 +109,8 @@ --     Info Tables ----------------------------------------------------------------------------- +-- | CmmTopInfo is attached to each CmmDecl (see defn of CmmGroup), and contains+-- the extra info (beyond the executable code) that belongs to that CmmDecl. data CmmTopInfo   = TopInfo { info_tbls  :: LabelMap CmmInfoTable                             , stack_info :: CmmStackInfo } @@ -121,8 +122,8 @@    = StackInfo {        arg_space :: ByteOff,                -- number of bytes of arguments on the stack on entry to the-               -- the proc.  This is filled in by StgCmm.codeGen, and used-               -- by the stack allocator later.+               -- the proc.  This is filled in by GHC.StgToCmm.codeGen, and+               -- used by the stack allocator later.        updfr_space :: Maybe ByteOff,                -- XXX: this never contains anything useful, but it should.                -- See comment in CmmLayoutStack.@@ -159,7 +160,7 @@  data ProfilingInfo   = NoProfilingInfo-  | ProfilingInfo [Word8] [Word8] -- closure_type, closure_desc+  | ProfilingInfo ByteString ByteString -- closure_type, closure_desc  ----------------------------------------------------------------------------- --              Static Data@@ -195,7 +196,7 @@         -- a literal value, size given by cmmLitRep of the literal.   | CmmUninitialised Int         -- uninitialised data, N bytes long-  | CmmString [Word8]+  | CmmString ByteString         -- string of 8-bit values only, not zero terminated.  data CmmStatics
compiler/cmm/CmmBuildInfoTables.hs view
@@ -16,10 +16,9 @@ import Hoopl.Collections import Hoopl.Dataflow import Module-import Platform+import GHC.Platform import Digraph import CLabel-import PprCmmDecl () import Cmm import CmmUtils import DynFlags@@ -28,9 +27,8 @@ import SMRep import UniqSupply import CostCentre-import StgCmmHeap+import GHC.StgToCmm.Heap -import PprCmm() import Control.Monad import Data.Map (Map) import qualified Data.Map as Map@@ -707,18 +705,16 @@      -- First resolve all the CAFLabels to SRTEntries     -- Implements the [Inline] optimisation.-    resolved =-       Set.fromList $-       catMaybes (map (resolveCAF srtMap) (Set.toList nonRec))+    resolved = mapMaybe (resolveCAF srtMap) (Set.toList nonRec)      -- The set of all SRTEntries in SRTs that we refer to from here.     allBelow =-      Set.unions [ lbls | caf <- Set.toList resolved+      Set.unions [ lbls | caf <- resolved                         , Just lbls <- [Map.lookup caf (flatSRTs topSRT)] ]      -- Remove SRTEntries that are also in an SRT that we refer to.     -- Implements the [Filter] optimisation.-    filtered = Set.difference resolved allBelow+    filtered = Set.difference (Set.fromList resolved) allBelow    srtTrace "oneSRT:"      (ppr cafs <+> ppr resolved <+> ppr allBelow <+> ppr filtered) $ return ()@@ -731,7 +727,7 @@     -- important that we don't do this for static functions or CAFs,     -- see Note [Invalid optimisation: shortcutting].     updateSRTMap srtEntry =-      when (not isCAF && not isStaticFun) $ do+      when (not isCAF && (not isStaticFun || isNothing srtEntry)) $ do         let newSRTMap = Map.fromList [(cafLbl, srtEntry) | cafLbl <- lbls]         put (Map.union newSRTMap srtMap)
compiler/cmm/CmmCallConv.hs view
@@ -10,10 +10,10 @@ import CmmExpr import SMRep import Cmm (Convention(..))-import PprCmm ()+import PprCmm () -- For Outputable instances  import DynFlags-import Platform+import GHC.Platform import Outputable  -- Calculate the 'GlobalReg' or stack locations for function call@@ -81,7 +81,6 @@                             | passFloatInXmm          -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss))                         (W64, (vs, fs, d:ds, ls, ss))                             | not passFloatInXmm      -> k (RegisterParam d, (vs, fs, ds, ls, ss))-                        (W80, _) -> panic "F80 unsupported register type"                         _ -> (assts, (r:rs))               int = case (w, regs) of                       (W128, _) -> panic "W128 unsupported register type"@@ -100,6 +99,7 @@ passFloatArgsInXmm :: DynFlags -> Bool passFloatArgsInXmm dflags = case platformArch (targetPlatform dflags) of                               ArchX86_64 -> True+                              ArchX86    -> False                               _          -> False  -- We used to spill vector registers to the stack since the LLVM backend didn't
compiler/cmm/CmmCommonBlockElim.hs view
@@ -13,7 +13,6 @@ import CmmUtils import CmmSwitch (eqSwitchTargetWith) import CmmContFlowOpt--- import PprCmm ()  import Hoopl.Block import Hoopl.Graph
compiler/cmm/CmmContFlowOpt.hs view
@@ -18,7 +18,7 @@ import BlockId import Cmm import CmmUtils-import CmmSwitch (mapSwitchTargets)+import CmmSwitch (mapSwitchTargets, switchTargetsToList) import Maybes import Panic import Util@@ -294,6 +294,13 @@             , likelyTrue l || (numPreds f > 1)             , Just cond' <- maybeInvertCmmExpr cond             = CmmCondBranch cond' f t (invertLikeliness l)++            -- If all jump destinations of a switch go to the+            -- same target eliminate the switch.+            | CmmSwitch _expr targets <- shortcut_last+            , (t:ts) <- switchTargetsToList targets+            , all (== t) ts+            = CmmBranch t              | otherwise             = shortcut_last
compiler/cmm/CmmExpr.hs view
@@ -5,7 +5,7 @@ {-# LANGUAGE UndecidableInstances #-}  module CmmExpr-    ( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr+    ( CmmExpr(..), cmmExprType, cmmExprWidth, cmmExprAlignment, maybeInvertCmmExpr     , CmmReg(..), cmmRegType, cmmRegWidth     , CmmLit(..), cmmLitType     , LocalReg(..), localRegType@@ -43,6 +43,8 @@ import Data.Set (Set) import qualified Data.Set as Set +import BasicTypes (Alignment, mkAlignment, alignmentOf)+ ----------------------------------------------------------------------------- --              CmmExpr -- An expression.  Expressions have no side effects.@@ -239,6 +241,13 @@ cmmExprWidth :: DynFlags -> CmmExpr -> Width cmmExprWidth dflags e = typeWidth (cmmExprType dflags e) +-- | Returns an alignment in bytes of a CmmExpr when it's a statically+-- known integer constant, otherwise returns an alignment of 1 byte.+-- The caller is responsible for using with a sensible CmmExpr+-- argument.+cmmExprAlignment :: CmmExpr -> Alignment+cmmExprAlignment (CmmLit (CmmInt intOff _)) = alignmentOf (fromInteger intOff)+cmmExprAlignment _                          = mkAlignment 1 -------- --- Negation for conditional branches @@ -474,6 +483,9 @@    FloatReg i == FloatReg j = i==j    DoubleReg i == DoubleReg j = i==j    LongReg i == LongReg j = i==j+   -- NOTE: XMM, YMM, ZMM registers actually are the same registers+   -- at least with respect to store at YMM i and then read from XMM i+   -- and similarly for ZMM etc.    XmmReg i == XmmReg j = i==j    YmmReg i == YmmReg j = i==j    ZmmReg i == ZmmReg j = i==j@@ -584,6 +596,9 @@ globalRegType _      (FloatReg _)      = cmmFloat W32 globalRegType _      (DoubleReg _)     = cmmFloat W64 globalRegType _      (LongReg _)       = cmmBits W64+-- TODO: improve the internal model of SIMD/vectorized registers+-- the right design SHOULd improve handling of float and double code too.+-- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim globalRegType _      (XmmReg _)        = cmmVec 4 (cmmBits W32) globalRegType _      (YmmReg _)        = cmmVec 8 (cmmBits W32) globalRegType _      (ZmmReg _)        = cmmVec 16 (cmmBits W32)
compiler/cmm/CmmImplementSwitchPlans.hs view
@@ -32,6 +32,7 @@ -- code generation. cmmImplementSwitchPlans :: DynFlags -> CmmGraph -> UniqSM CmmGraph cmmImplementSwitchPlans dflags g+    -- Switch generation done by backend (LLVM/C)     | targetSupportsSwitch (hscTarget dflags) = return g     | otherwise = do     blocks' <- concat `fmap` mapM (visitSwitches dflags) (toBlockList g)@@ -39,18 +40,41 @@  visitSwitches :: DynFlags -> CmmBlock -> UniqSM [CmmBlock] visitSwitches dflags block-  | (entry@(CmmEntry _ scope), middle, CmmSwitch expr ids) <- blockSplit block+  | (entry@(CmmEntry _ scope), middle, CmmSwitch vanillaExpr ids) <- blockSplit block   = do     let plan = createSwitchPlan ids+    -- See Note [Floating switch expressions]+    (assignSimple, simpleExpr) <- floatSwitchExpr dflags vanillaExpr -    (newTail, newBlocks) <- implementSwitchPlan dflags scope expr plan+    (newTail, newBlocks) <- implementSwitchPlan dflags scope simpleExpr plan -    let block' = entry `blockJoinHead` middle `blockAppend` newTail+    let block' = entry `blockJoinHead` middle `blockAppend` assignSimple `blockAppend` newTail      return $ block' : newBlocks    | otherwise   = return [block]++-- Note [Floating switch expressions]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++-- When we translate a sparse switch into a search tree we would like+-- to compute the value we compare against only once.++-- For this purpose we assign the switch expression to a local register+-- and then use this register when constructing the actual binary tree.++-- This is important as the expression could contain expensive code like+-- memory loads or divisions which we REALLY don't want to duplicate.++-- This happened in parts of the handwritten RTS Cmm code. See also #16933++-- See Note [Floating switch expressions]+floatSwitchExpr :: DynFlags -> CmmExpr -> UniqSM (Block CmmNode O O, CmmExpr)+floatSwitchExpr _      reg@(CmmReg {})  = return (emptyBlock, reg)+floatSwitchExpr dflags expr             = do+  (assign, expr') <- cmmMkAssign dflags expr <$> getUniqueM+  return (BMiddle assign, expr')   -- Implementing a switch plan (returning a tail block)
compiler/cmm/CmmInfo.hs view
@@ -32,7 +32,7 @@   stdPtrsOffset, stdNonPtrsOffset, ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -45,17 +45,18 @@ import qualified Stream import Hoopl.Collections -import Platform+import GHC.Platform import Maybes import DynFlags+import ErrUtils (withTimingSilent) import Panic import UniqSupply import MonadUtils import Util import Outputable +import Data.ByteString (ByteString) import Data.Bits-import Data.Word  -- When we split at proc points, we need an empty info table. mkEmptyContInfoTable :: CLabel -> CmmInfoTable@@ -66,17 +67,23 @@                  , cit_srt  = Nothing                  , cit_clo  = Nothing } -cmmToRawCmm :: DynFlags -> Stream IO CmmGroup ()-            -> IO (Stream IO RawCmmGroup ())+cmmToRawCmm :: DynFlags -> Stream IO CmmGroup a+            -> IO (Stream IO RawCmmGroup a) cmmToRawCmm dflags cmms   = do { uniqs <- mkSplitUniqSupply 'i'-       ; let do_one uniqs cmm = do-                case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of-                  (b,uniqs') -> return (uniqs',b)-                  -- NB. strictness fixes a space leak.  DO NOT REMOVE.-       ; return (Stream.mapAccumL do_one uniqs cmms >> return ())+       ; let do_one :: UniqSupply -> [CmmDecl] -> IO (UniqSupply, [RawCmmDecl])+             do_one uniqs cmm =+               -- NB. strictness fixes a space leak.  DO NOT REMOVE.+               withTimingSilent dflags (text "Cmm -> Raw Cmm")+                                forceRes $+                 case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of+                   (b,uniqs') -> return (uniqs',b)+       ; return (snd <$> Stream.mapAccumL_ do_one uniqs cmms)        } +    where forceRes (uniqs, rawcmms) =+            uniqs `seq` foldr (\decl r -> decl `seq` r) () rawcmms+ -- Make a concrete info table, represented as a list of CmmStatic -- (it can't be simply a list of Word, because the SRT field is -- represented by a label+offset expression).@@ -416,7 +423,7 @@        ; (cd_lit, cd_decl) <- newStringLit cd        ; return ((td_lit,cd_lit), [td_decl,cd_decl]) } -newStringLit :: [Word8] -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)+newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt) newStringLit bytes   = do { uniq <- getUniqueM        ; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) }@@ -531,7 +538,7 @@     | otherwise               = ( pc_REP_StgFunInfoExtraFwd_arity pc                                 , oFFSET_StgFunInfoExtraFwd_arity dflags ) -   pc = sPlatformConstants (settings dflags)+   pc = platformConstants dflags  ----------------------------------------------------------------------------- --@@ -572,7 +579,7 @@ stdSrtBitmapOffset :: DynFlags -> ByteOff -- Byte offset of the SRT bitmap half-word which is -- in the *higher-addressed* part of the type_lit-stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE dflags+stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - halfWordSize dflags  stdClosureTypeOffset :: DynFlags -> ByteOff -- Byte offset of the closure type half-word@@ -580,7 +587,7 @@  stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff stdPtrsOffset    dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags-stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags+stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + halfWordSize dflags  conInfoTableSizeB :: DynFlags -> Int conInfoTableSizeB dflags = stdInfoTableSizeB dflags + wORD_SIZE dflags
compiler/cmm/CmmLayoutStack.hs view
@@ -5,8 +5,8 @@  import GhcPrelude hiding ((<*>)) -import StgCmmUtils      ( callerSaveVolatileRegs ) -- XXX layering violation-import StgCmmForeign    ( saveThreadState, loadThreadState ) -- XXX layering violation+import GHC.StgToCmm.Utils      ( callerSaveVolatileRegs, newTemp  ) -- XXX layering violation+import GHC.StgToCmm.Foreign    ( saveThreadState, loadThreadState ) -- XXX layering violation  import BasicTypes import Cmm@@ -25,7 +25,6 @@ import Hoopl.Graph import Hoopl.Label import UniqSupply-import StgCmmUtils      ( newTemp ) import Maybes import UniqFM import Util@@ -918,7 +917,7 @@ areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark)   = mkIntExpr dflags sp_hwm     -- Replace CmmHighStackMark with the number of bytes of stack used,-    -- the sp_hwm.   See Note [Stack usage] in StgCmmHeap+    -- the sp_hwm.   See Note [Stack usage] in GHC.StgToCmm.Heap  areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) args)   | falseStackCheck args
compiler/cmm/CmmLint.hs view
@@ -5,6 +5,7 @@ -- CmmLint: checking the correctness of Cmm statements and expressions -- -----------------------------------------------------------------------------+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-} module CmmLint (     cmmLint, cmmLintGraph@@ -20,11 +21,11 @@ import CmmUtils import CmmLive import CmmSwitch (switchTargetsToList)-import PprCmm ()+import PprCmm () -- For Outputable instances import Outputable import DynFlags -import Control.Monad (liftM, ap)+import Control.Monad (ap)  -- Things to check: --     - invariant on CmmBlock in CmmExpr (see comment there)@@ -212,9 +213,7 @@ -- just a basic error monad:  newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a }--instance Functor CmmLint where-      fmap = liftM+    deriving (Functor)  instance Applicative CmmLint where       pure a = CmmLint (\_ -> Right a)
compiler/cmm/CmmLive.hs view
@@ -17,7 +17,7 @@ import DynFlags import BlockId import Cmm-import PprCmmExpr ()+import PprCmmExpr () -- For Outputable instances import Hoopl.Block import Hoopl.Collections import Hoopl.Dataflow
compiler/cmm/CmmMachOp.hs view
@@ -556,7 +556,9 @@   | MO_F64_Acosh   | MO_F64_Atanh   | MO_F64_Log+  | MO_F64_Log1P   | MO_F64_Exp+  | MO_F64_ExpM1   | MO_F64_Fabs   | MO_F64_Sqrt   | MO_F32_Pwr@@ -573,7 +575,9 @@   | MO_F32_Acosh   | MO_F32_Atanh   | MO_F32_Log+  | MO_F32_Log1P   | MO_F32_Exp+  | MO_F32_ExpM1   | MO_F32_Fabs   | MO_F32_Sqrt @@ -618,6 +622,7 @@   | MO_Ctz Width    | MO_BSwap Width+  | MO_BRev Width    -- Atomic read-modify-write.   | MO_AtomicRMW Width AtomicMachOp
compiler/cmm/CmmMonad.hs view
@@ -50,7 +50,7 @@ (PD m) `thenPD` k = PD $ \d s ->         case m d s of                 POk s1 a         -> unPD (k a) d s1-                PFailed warnFn span err -> PFailed warnFn span err+                PFailed s1 -> PFailed s1  failPD :: String -> PD a failPD = liftP . fail
compiler/cmm/CmmNode.hs view
@@ -26,7 +26,7 @@  import GhcPrelude hiding (succ) -import CodeGen.Platform+import GHC.Platform.Regs import CmmExpr import CmmSwitch import DynFlags@@ -90,7 +90,7 @@       -- See Note [Unsafe foreign calls clobber caller-save registers]       --       -- Invariant: the arguments and the ForeignTarget must not-      -- mention any registers for which CodeGen.Platform.callerSaves+      -- mention any registers for which GHC.Platform.callerSaves       -- is True.  See Note [Register Parameter Passing].    CmmBranch :: ULabel -> CmmNode O C@@ -114,7 +114,7 @@       cml_cont :: Maybe Label,           -- Label of continuation (Nothing for return or tail call)           ---          -- Note [Continuation BlockId]: these BlockIds are called+          -- Note [Continuation BlockIds]: these BlockIds are called           -- Continuation BlockIds, and are the only BlockIds that can           -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or           -- (CmmStackSlot (Young b) _).@@ -199,7 +199,7 @@  A foreign call is defined to clobber any GlobalRegs that are mapped to caller-saves machine registers (according to the prevailing C ABI).-StgCmmUtils.callerSaves tells you which GlobalRegs are caller-saves.+GHC.StgToCmm.Utils.callerSaves tells you which GlobalRegs are caller-saves.  This is a design choice that makes it easier to generate code later. We could instead choose to say that foreign calls do *not* clobber@@ -221,7 +221,7 @@ argument passing.  These are registers R3-R6, which our generated code may also be using; as a result, it's necessary to save these values before doing a foreign call.  This is done during initial-code generation in callerSaveVolatileRegs in StgCmmUtils.hs.  However,+code generation in callerSaveVolatileRegs in GHC.StgToCmm.Utils.  However, one result of doing this is that the contents of these registers may mysteriously change if referenced inside the arguments.  This is dangerous, so you'll need to disable inlining much in the same
compiler/cmm/CmmOpt.hs view
@@ -1,7 +1,3 @@--- The default iteration limit is a bit too low for the definitions--- in this module.-{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}- ----------------------------------------------------------------------------- -- -- Cmm optimisation@@ -25,7 +21,7 @@ import Util  import Outputable-import Platform+import GHC.Platform  import Data.Bits import Data.Maybe
compiler/cmm/CmmParse.y view
@@ -198,26 +198,27 @@ ----------------------------------------------------------------------------- -}  {+{-# LANGUAGE TupleSections #-}+ module CmmParse ( parseCmmFile ) where  import GhcPrelude-import qualified Prelude -import StgCmmExtCode+import GHC.StgToCmm.ExtCode import CmmCallConv-import StgCmmProf-import StgCmmHeap-import StgCmmMonad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit, emitStore-                          , emitAssign, emitOutOfLine, withUpdFrameOff-                          , getUpdFrameOff )-import qualified StgCmmMonad as F-import StgCmmUtils-import StgCmmForeign-import StgCmmExpr-import StgCmmClosure-import StgCmmLayout     hiding (ArgRep(..))-import StgCmmTicky-import StgCmmBind       ( emitBlackHoleCode, emitUpdateFrame )+import GHC.StgToCmm.Prof+import GHC.StgToCmm.Heap+import GHC.StgToCmm.Monad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit+                               , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff+                               , getUpdFrameOff )+import qualified GHC.StgToCmm.Monad as F+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Foreign+import GHC.StgToCmm.Expr+import GHC.StgToCmm.Closure+import GHC.StgToCmm.Layout     hiding (ArgRep(..))+import GHC.StgToCmm.Ticky+import GHC.StgToCmm.Bind  ( emitBlackHoleCode, emitUpdateFrame ) import CoreSyn          ( Tickish(SourceNote) )  import CmmOpt@@ -236,7 +237,7 @@ import CostCentre import ForeignCall import Module-import Platform+import GHC.Platform import Literal import Unique import UniqFM@@ -258,8 +259,9 @@ import System.Exit import Data.Maybe import qualified Data.Map as M+import qualified Data.ByteString.Char8 as BS8 -#include "GhclibHsVersions.h"+#include "HsVersions.h" }  %expect 0@@ -373,8 +375,8 @@ cmmtop  :: { CmmParse () }         : cmmproc                       { $1 }         | cmmdata                       { $1 }-        | decl                          { $1 } -        | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'  +        | decl                          { $1 }+        | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'                 {% liftP . withThisPackage $ \pkg ->                    do lits <- sequence $6;                       staticClosure pkg $3 $5 (map getLit lits) }@@ -389,30 +391,30 @@ --      * we can derive closure and info table labels from a single NAME  cmmdata :: { CmmParse () }-        : 'section' STRING '{' data_label statics '}' +        : 'section' STRING '{' data_label statics '}'                 { do lbl <- $4;                      ss <- sequence $5;                      code (emitDecl (CmmData (Section (section $2) lbl) (Statics lbl $ concat ss))) }  data_label :: { CmmParse CLabel }-    : NAME ':'  +    : NAME ':'                 {% liftP . withThisPackage $ \pkg ->                    return (mkCmmDataLabel pkg $1) }  statics :: { [CmmParse [CmmStatic]] }         : {- empty -}                   { [] }         | static statics                { $1 : $2 }-    + static  :: { CmmParse [CmmStatic] }         : type expr ';' { do e <- $2;                              return [CmmStaticLit (getLit e)] }         | type ';'                      { return [CmmUninitialised                                                         (widthInBytes (typeWidth $1))] }         | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }-        | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised +        | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised                                                         (fromIntegral $3)] }-        | typenot8 '[' INT ']' ';'      { return [CmmUninitialised -                                                (widthInBytes (typeWidth $1) * +        | typenot8 '[' INT ']' ';'      { return [CmmUninitialised+                                                (widthInBytes (typeWidth $1) *                                                         fromIntegral $3)] }         | 'CLOSURE' '(' NAME lits ')'                 { do { lits <- sequence $4@@ -473,7 +475,7 @@                                            , cit_rep = rep                                            , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },                               []) }-        +         | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'                 -- ptrs, nptrs, closure type, description, type, fun type                 {% liftP . withThisPackage $ \pkg ->@@ -498,7 +500,7 @@                    do dflags <- getDynFlags                       let prof = profilingInfo dflags $13 $15                           ty  = Constr (fromIntegral $9)  -- Tag-                                       (stringToWord8s $13)+                                       (BS8.pack $13)                           rep = mkRTSRep (fromIntegral $11) $                                   mkHeapRep dflags False (fromIntegral $5)                                                   (fromIntegral $7) ty@@ -510,7 +512,7 @@                       -- If profiling is on, this string gets duplicated,                      -- but that's the way the old code did it we can fix it some other time.-        +         | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'                 -- selector, closure type, description, type                 {% liftP . withThisPackage $ \pkg ->@@ -573,7 +575,7 @@          -- A label imported without an explicit packageId.         --      These are taken to come frome some foreign, unnamed package.-        : NAME  +        : NAME         { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }          -- as previous 'NAME', but 'IsData'@@ -583,8 +585,8 @@         -- A label imported with an explicit packageId.         | STRING NAME         { ($2, mkCmmCodeLabel (fsToUnitId (mkFastString $1)) $2) }-        -        ++ names   :: { [FastString] }         : NAME                          { [$1] }         | NAME ',' names                { $1 : $3 }@@ -670,9 +672,9 @@         | expr                          { do e <- $1; return (BoolTest e) }  bool_op :: { CmmParse BoolExpr }-        : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3; +        : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3;                                           return (BoolAnd e1 e2) }-        | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3; +        | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3;                                           return (BoolOr e1 e2)  }         | '!' bool_expr                 { do e <- $2; return (BoolNot e) }         | '(' bool_op ')'               { $2 }@@ -758,7 +760,7 @@ expr0   :: { CmmParse CmmExpr }         : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }         | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }-        | STRING                 { do s <- code (newStringCLit $1); +        | STRING                 { do s <- code (newStringCLit $1);                                       return (CmmLit s) }         | reg                    { $1 }         | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }@@ -808,7 +810,7 @@         | foreign_formal ',' foreign_formals    { $1 : $3 }  foreign_formal :: { CmmParse (LocalReg, ForeignHint) }-        : local_lreg            { do e <- $1; return (e, (inferCmmHint (CmmReg (CmmLocal e)))) }+        : local_lreg            { do e <- $1; return (e, inferCmmHint (CmmReg (CmmLocal e))) }         | STRING local_lreg     {% do h <- parseCmmHint $1;                                       return $ do                                          e <- $2; return (e,h) }@@ -816,14 +818,14 @@ local_lreg :: { CmmParse LocalReg }         : NAME                  { do e <- lookupName $1;                                      return $-                                       case e of +                                       case e of                                         CmmReg (CmmLocal r) -> r                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }  lreg    :: { CmmParse CmmReg }         : NAME                  { do e <- lookupName $1;                                      return $-                                       case e of +                                       case e of                                         CmmReg r -> r                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }         | GLOBALREG             { return (CmmGlobal $1) }@@ -869,7 +871,7 @@ section s           = OtherSection s  mkString :: String -> CmmStatic-mkString s = CmmString (map (fromIntegral.ord) s)+mkString s = CmmString (BS8.pack s)  -- | -- Given an info table, decide what the entry convention for the proc@@ -999,37 +1001,37 @@ callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr])) callishMachOps = listToUFM $         map (\(x, y) -> (mkFastString x, y)) [-        ( "read_barrier", (,) MO_ReadBarrier ),-        ( "write_barrier", (,) MO_WriteBarrier ),+        ( "read_barrier", (MO_ReadBarrier,)),+        ( "write_barrier", (MO_WriteBarrier,)),         ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),         ( "memset", memcpyLikeTweakArgs MO_Memset ),         ( "memmove", memcpyLikeTweakArgs MO_Memmove ),         ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ), -        ("prefetch0", (,) $ MO_Prefetch_Data 0),-        ("prefetch1", (,) $ MO_Prefetch_Data 1),-        ("prefetch2", (,) $ MO_Prefetch_Data 2),-        ("prefetch3", (,) $ MO_Prefetch_Data 3),+        ("prefetch0", (MO_Prefetch_Data 0,)),+        ("prefetch1", (MO_Prefetch_Data 1,)),+        ("prefetch2", (MO_Prefetch_Data 2,)),+        ("prefetch3", (MO_Prefetch_Data 3,)), -        ( "popcnt8",  (,) $ MO_PopCnt W8  ),-        ( "popcnt16", (,) $ MO_PopCnt W16 ),-        ( "popcnt32", (,) $ MO_PopCnt W32 ),-        ( "popcnt64", (,) $ MO_PopCnt W64 ),+        ( "popcnt8",  (MO_PopCnt W8,)),+        ( "popcnt16", (MO_PopCnt W16,)),+        ( "popcnt32", (MO_PopCnt W32,)),+        ( "popcnt64", (MO_PopCnt W64,)), -        ( "pdep8",  (,) $ MO_Pdep W8  ),-        ( "pdep16", (,) $ MO_Pdep W16 ),-        ( "pdep32", (,) $ MO_Pdep W32 ),-        ( "pdep64", (,) $ MO_Pdep W64 ),+        ( "pdep8",  (MO_Pdep W8,)),+        ( "pdep16", (MO_Pdep W16,)),+        ( "pdep32", (MO_Pdep W32,)),+        ( "pdep64", (MO_Pdep W64,)), -        ( "pext8",  (,) $ MO_Pext W8  ),-        ( "pext16", (,) $ MO_Pext W16 ),-        ( "pext32", (,) $ MO_Pext W32 ),-        ( "pext64", (,) $ MO_Pext W64 ),+        ( "pext8",  (MO_Pext W8,)),+        ( "pext16", (MO_Pext W16,)),+        ( "pext32", (MO_Pext W32,)),+        ( "pext64", (MO_Pext W64,)), -        ( "cmpxchg8",  (,) $ MO_Cmpxchg W8  ),-        ( "cmpxchg16", (,) $ MO_Cmpxchg W16 ),-        ( "cmpxchg32", (,) $ MO_Cmpxchg W32 ),-        ( "cmpxchg64", (,) $ MO_Cmpxchg W64 )+        ( "cmpxchg8",  (MO_Cmpxchg W8,)),+        ( "cmpxchg16", (MO_Cmpxchg W16,)),+        ( "cmpxchg32", (MO_Cmpxchg W32,)),+        ( "cmpxchg64", (MO_Cmpxchg W64,))          -- ToDo: the rest, maybe         -- edit: which rest?@@ -1167,8 +1169,7 @@ profilingInfo dflags desc_str ty_str   = if not (gopt Opt_SccProfilingOn dflags)     then NoProfilingInfo-    else ProfilingInfo (stringToWord8s desc_str)-                       (stringToWord8s ty_str)+    else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str)  staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse () staticClosure pkg cl_label info payload@@ -1375,7 +1376,7 @@ doSwitch mb_range scrut arms deflt    = do         -- Compile code for the default branch-        dflt_entry <- +        dflt_entry <-                 case deflt of                   Nothing -> return Nothing                   Just e  -> do b <- forkLabelledCode e; return (Just b)@@ -1418,7 +1419,7 @@   ]  parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)-parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do+parseCmmFile dflags filename = withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do   buf <- hGetStringBuffer filename   let         init_loc = mkRealSrcLoc (mkFastString filename) 1 1@@ -1426,11 +1427,8 @@                 -- reset the lex_state: the Lexer monad leaves some stuff                 -- in there we don't want.   case unPD cmmParse dflags init_state of-    PFailed warnFn span err -> do-        let msg = mkPlainErrMsg dflags span err-            errMsgs = (emptyBag, unitBag msg)-            warnMsgs = warnFn dflags-        return (unionMessages warnMsgs errMsgs, Nothing)+    PFailed pst ->+        return (getMessages pst dflags, Nothing)     POk pst code -> do         st <- initC         let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()
compiler/cmm/CmmPipeline.hs view
@@ -26,7 +26,7 @@ import HscTypes import Control.Monad import Outputable-import Platform+import GHC.Platform  ----------------------------------------------------------------------------- -- | Top level driver for C-- pipeline@@ -39,7 +39,7 @@  -> CmmGroup             -- Input C-- with Procedures  -> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C-- -cmmPipeline hsc_env srtInfo prog =+cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline") forceRes $   do let dflags = hsc_dflags hsc_env       tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog@@ -49,7 +49,11 @@       return (srtInfo, cmms) +  where forceRes (info, group) =+          info `seq` foldr (\decl r -> decl `seq` r) () group +        dflags = hsc_dflags hsc_env+ cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl]) cpsTop _ p@(CmmData {}) = return (mapEmpty, [p]) cpsTop hsc_env proc =@@ -75,6 +79,7 @@        -- Any work storing block Labels must be performed _after_        -- elimCommonBlocks +       ----------- Implement switches ------------------------------------------        g <- {-# SCC "createSwitchPlans" #-}             runUniqSM $ cmmImplementSwitchPlans dflags g        dump Opt_D_dump_cmm_switch "Post switch plan" g@@ -352,9 +357,10 @@  dumpWith :: DynFlags -> DumpFlag -> String -> SDoc -> IO () dumpWith dflags flag txt sdoc = do-         -- ToDo: No easy way of say "dump all the cmm, *and* split-         -- them into files."  Also, -ddump-cmm-verbose doesn't play-         -- nicely with -ddump-to-file, since the headers get omitted.-   dumpIfSet_dyn dflags flag txt sdoc-   when (not (dopt flag dflags)) $-      dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose txt sdoc+  dumpIfSet_dyn dflags flag txt sdoc+  when (not (dopt flag dflags)) $+    -- If `-ddump-cmm-verbose -ddump-to-file` is specified,+    -- dump each Cmm pipeline stage output to a separate file.  #16930+    when (dopt Opt_D_dump_cmm_verbose dflags)+      $ dumpSDoc dflags alwaysQualify flag txt sdoc+  dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc txt sdoc
compiler/cmm/CmmProcPoint.hs view
@@ -14,7 +14,7 @@ import BlockId import CLabel import Cmm-import PprCmm ()+import PprCmm () -- For Outputable instances import CmmUtils import CmmInfo import CmmLive@@ -23,7 +23,7 @@ import Maybes import Control.Monad import Outputable-import Platform+import GHC.Platform import UniqSupply import Hoopl.Block import Hoopl.Collections
compiler/cmm/CmmSink.hs view
@@ -13,13 +13,12 @@ import Hoopl.Label import Hoopl.Collections import Hoopl.Graph-import CodeGen.Platform-import Platform (isARM, platformArch)+import GHC.Platform.Regs+import GHC.Platform (isARM, platformArch)  import DynFlags import Unique import UniqFM-import PprCmm ()  import qualified Data.IntSet as IntSet import Data.List (partition)@@ -133,7 +132,7 @@ -- -- a nice loop, but we didn't eliminate the silly assignment at the end. -- See Note [dependent assignments], which would probably fix this.--- This is #8336 on Trac.+-- This is #8336. -- -- ----------- -- (2) From stg_atomically_frame in PrimOps.cmm@@ -566,7 +565,7 @@ -- clashing with C argument-passing registers, really the back-end -- ought to be able to handle it properly, but currently neither PprC -- nor the NCG can do it.  See Note [Register parameter passing]--- See also StgCmmForeign:load_args_into_temps.+-- See also GHC.StgToCmm.Foreign.load_args_into_temps. okToInline :: DynFlags -> CmmExpr -> CmmNode e x -> Bool okToInline dflags expr node@(CmmUnsafeForeignCall{}) =     not (globalRegistersConflict dflags expr node)
compiler/cmm/CmmSwitch.hs view
@@ -32,7 +32,7 @@ -- -- The overall plan is: --  * The Stg → Cmm transformation creates a single `SwitchTargets` in---    emitSwitch and emitCmmLitSwitch in StgCmmUtils.hs.+--    emitSwitch and emitCmmLitSwitch in GHC.StgToCmm/Utils.hs. --    At this stage, they are unsuitable for code generation. --  * A dedicated Cmm transformation (CmmImplementSwitchPlans) replaces these --    switch statements with code that is suitable for code generation, i.e.
compiler/cmm/CmmUtils.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs, RankNTypes #-}+{-# LANGUAGE BangPatterns #-}  ----------------------------------------------------------------------------- --@@ -35,6 +36,8 @@         cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord,         cmmToWord, +        cmmMkAssign,+         isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr,          baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,@@ -76,9 +79,11 @@ import CLabel import Outputable import DynFlags-import CodeGen.Platform+import Unique+import GHC.Platform.Regs -import Data.Word+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS import Data.Bits import Hoopl.Graph import Hoopl.Label@@ -101,6 +106,8 @@ primRepCmmType _      Word8Rep         = b8 primRepCmmType _      Int16Rep         = b16 primRepCmmType _      Word16Rep        = b16+primRepCmmType _      Int32Rep         = b32+primRepCmmType _      Word32Rep        = b32 primRepCmmType _      Int64Rep         = b64 primRepCmmType _      Word64Rep        = b64 primRepCmmType dflags AddrRep          = bWord dflags@@ -137,10 +144,12 @@ primRepForeignHint IntRep       = SignedHint primRepForeignHint Int8Rep      = SignedHint primRepForeignHint Int16Rep     = SignedHint+primRepForeignHint Int32Rep     = SignedHint primRepForeignHint Int64Rep     = SignedHint primRepForeignHint WordRep      = NoHint primRepForeignHint Word8Rep     = NoHint primRepForeignHint Word16Rep    = NoHint+primRepForeignHint Word32Rep    = NoHint primRepForeignHint Word64Rep    = NoHint primRepForeignHint AddrRep      = AddrHint -- NB! AddrHint, but NonPtrArg primRepForeignHint FloatRep     = NoHint@@ -181,7 +190,7 @@ mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)  mkByteStringCLit-  :: CLabel -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt)+  :: CLabel -> ByteString -> (CmmLit, GenCmmDecl CmmStatics info stmt) -- We have to make a top-level decl for the string, -- and return a literal pointing to it mkByteStringCLit lbl bytes@@ -189,7 +198,7 @@   where     -- This can not happen for String literals (as there \NUL is replaced by     -- C0 80). However, it can happen with Addr# literals.-    sec = if 0 `elem` bytes then ReadOnlyData else CString+    sec = if 0 `BS.elem` bytes then ReadOnlyData else CString  mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt -- Build a data-segment data block@@ -218,8 +227,8 @@ --       but be careful: that's vulnerable when reversed packHalfWordsCLit dflags lower_half_word upper_half_word    = if wORDS_BIGENDIAN dflags-     then mkWordCLit dflags ((l `shiftL` hALF_WORD_SIZE_IN_BITS dflags) .|. u)-     else mkWordCLit dflags (l .|. (u `shiftL` hALF_WORD_SIZE_IN_BITS dflags))+     then mkWordCLit dflags ((l `shiftL` halfWordSizeInBits dflags) .|. u)+     else mkWordCLit dflags (l .|. (u `shiftL` halfWordSizeInBits dflags))     where l = fromStgHalfWord lower_half_word           u = fromStgHalfWord upper_half_word @@ -371,6 +380,13 @@     w = cmmExprWidth dflags e     word = wordWidth dflags +cmmMkAssign :: DynFlags -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr)+cmmMkAssign dflags expr uq =+  let !ty = cmmExprType dflags expr+      reg = (CmmLocal (LocalReg uq ty))+  in  (CmmAssign reg expr, CmmReg reg)++ --------------------------------------------------- -- --      CmmExpr predicates@@ -447,7 +463,7 @@ -- -- We must check for overlapping registers and not just equal -- registers here, otherwise CmmSink may incorrectly reorder--- assignments that conflict due to overlap. See Trac #10521 and Note+-- assignments that conflict due to overlap. See #10521 and Note -- [Overlapping global registers]. regUsedIn :: DynFlags -> CmmReg -> CmmExpr -> Bool regUsedIn dflags = regUsedIn_ where
compiler/cmm/Debug.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-}  ----------------------------------------------------------------------------- --@@ -11,7 +12,7 @@  module Debug ( -  DebugBlock(..), dblIsEntry,+  DebugBlock(..),   cmmDebugGen,   cmmDebugLabels,   cmmDebugLink,@@ -32,7 +33,6 @@ import FastString      ( nilFS, mkFastString ) import Module import Outputable-import PprCore         () import PprCmmExpr      ( pprExpr ) import SrcLoc import Util            ( seqList )@@ -59,8 +59,7 @@   , dblParent     :: !(Maybe DebugBlock)     -- ^ The parent of this proc. See Note [Splitting DebugBlocks]   , dblTicks      :: ![CmmTickish] -- ^ Ticks defined in this block-  , dblSourceTick-            :: !(Maybe CmmTickish) -- ^ Best source tick covering block+  , dblSourceTick :: !(Maybe CmmTickish) -- ^ Best source tick covering block   , dblPosition   :: !(Maybe Int)  -- ^ Output position relative to                                    -- other blocks. @Nothing@ means                                    -- the block was optimized out@@ -68,22 +67,19 @@   , dblBlocks     :: ![DebugBlock] -- ^ Nested blocks   } --- | Is this the entry block?-dblIsEntry :: DebugBlock -> Bool-dblIsEntry blk = dblProcedure blk == dblLabel blk- instance Outputable DebugBlock where-  ppr blk = (if dblProcedure blk == dblLabel blk-             then text "proc "-             else if dblHasInfoTbl blk-                  then text "pp-blk "-                  else text "blk ") <>+  ppr blk = (if | dblProcedure blk == dblLabel blk+                -> text "proc"+                | dblHasInfoTbl blk+                -> text "pp-blk"+                | otherwise+                -> text "blk") <+>             ppr (dblLabel blk) <+> parens (ppr (dblCLabel blk)) <+>             (maybe empty ppr (dblSourceTick blk)) <+>             (maybe (text "removed") ((text "pos " <>) . ppr)                    (dblPosition blk)) <+>-            (ppr (dblUnwind blk)) <+>-            (if null (dblBlocks blk) then empty else ppr (dblBlocks blk))+            (ppr (dblUnwind blk)) $+$+            (if null (dblBlocks blk) then empty else nest 4 (ppr (dblBlocks blk)))  -- | Intermediate data structure holding debug-relevant context information -- about a block.@@ -369,7 +365,7 @@  The flow of unwinding information through the compiler is a bit convoluted: - * C-- begins life in StgCmm without any unwind information. This is because we+ * C-- begins life in StgToCmm without any unwind information. This is because we    haven't actually done any register assignment or stack layout yet, so there    is no need for unwind information.
compiler/cmm/Hoopl/Block.hs view
@@ -1,10 +1,15 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} module Hoopl.Block-    ( C+    ( Extensibility (..)     , O+    , C     , MaybeO(..)     , IndexedCO     , Block(..)@@ -38,19 +43,21 @@ -- ----------------------------------------------------------------------------- -- Shapes: Open and Closed --- | Used at the type level to indicate an "open" structure with--- a unique, unnamed control-flow edge flowing in or out.--- "Fallthrough" and concatenation are permitted at an open point.-data O+-- | Used at the type level to indicate "open" vs "closed" structure.+data Extensibility+  -- | An "open" structure with a unique, unnamed control-flow edge flowing in+  -- or out. "Fallthrough" and concatenation are permitted at an open point.+  = Open+  -- | A "closed" structure which supports control transfer only through the use+  -- of named labels---no "fallthrough" is permitted. The number of control-flow+  -- edges is unconstrained.+  | Closed --- | Used at the type level to indicate a "closed" structure which--- supports control transfer only through the use of named--- labels---no "fallthrough" is permitted.  The number of control-flow--- edges is unconstrained.-data C+type O = 'Open+type C = 'Closed  -- | Either type indexed by closed/open using type families-type family IndexedCO ex a b :: *+type family IndexedCO (ex :: Extensibility) (a :: k) (b :: k) :: k type instance IndexedCO C a _b = a type instance IndexedCO O _a b = b @@ -64,14 +71,8 @@   JustC    :: t -> MaybeC C t   NothingC ::      MaybeC O t --instance Functor (MaybeO ex) where-  fmap _ NothingO = NothingO-  fmap f (JustO a) = JustO (f a)--instance Functor (MaybeC ex) where-  fmap _ NothingC = NothingC-  fmap f (JustC a) = JustC (f a)+deriving instance Functor (MaybeO ex)+deriving instance Functor (MaybeC ex)  -- ----------------------------------------------------------------------------- -- The Block type
compiler/cmm/Hoopl/Dataflow.hs view
@@ -1,10 +1,10 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses  #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -fprof-auto-top #-}  -- -- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones,@@ -49,7 +49,7 @@ import Hoopl.Collections import Hoopl.Label -type family   Fact x f :: *+type family   Fact (x :: Extensibility) f :: * type instance Fact C f = FactBase f type instance Fact O f = f @@ -106,6 +106,7 @@     -> FactBase f     -> FactBase f analyzeCmm dir lattice transfer cmmGraph initFact =+    {-# SCC analyzeCmm #-}     let entry = g_entry cmmGraph         hooplGraph = g_graph cmmGraph         blockMap =@@ -167,7 +168,7 @@     -> CmmGraph     -> FactBase f     -> UniqSM (CmmGraph, FactBase f)-rewriteCmm dir lattice rwFun cmmGraph initFact = do+rewriteCmm dir lattice rwFun cmmGraph initFact = {-# SCC rewriteCmm #-} do     let entry = g_entry cmmGraph         hooplGraph = g_graph cmmGraph         blockMap1 =
compiler/cmm/Hoopl/Graph.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-}@@ -30,7 +31,7 @@ type Body n = LabelMap (Block n C C)  -- | @Body@ abstracted over @block@-type Body' block (n :: * -> * -> *) = LabelMap (block n C C)+type Body' block (n :: Extensibility -> Extensibility -> *) = LabelMap (block n C C)  ------------------------------- -- | Gives access to the anchor points for@@ -75,7 +76,7 @@ -- | @Graph'@ is abstracted over the block type, so that we can build -- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow -- needs this).-data Graph' block (n :: * -> * -> *) e x where+data Graph' block (n :: Extensibility -> Extensibility -> *) e x where   GNil  :: Graph' block n O O   GUnit :: block n O O -> Graph' block n O O   GMany :: MaybeO e (block n O C)
compiler/cmm/MkGraph.hs view
@@ -335,8 +335,8 @@           local = CmmLocal reg           width = cmmRegWidth dflags local           expr  = CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [stack_slot]-        in CmmAssign local expr -         +        in CmmAssign local expr+       | otherwise =          CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)          where ty = localRegType reg
compiler/cmm/PprC.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, GADTs #-}+{-# LANGUAGE CPP, DeriveFunctor, GADTs, PatternSynonyms #-}  ----------------------------------------------------------------------------- --@@ -8,7 +8,7 @@ -- -- Print Cmm as real C, for -fvia-C ----- See wiki:Commentary/Compiler/Backends/PprC+-- See wiki:commentary/compiler/backends/ppr-c -- -- This is simpler than the old PprAbsC, because Cmm is "macro-expanded" -- relative to the old AbstractC, and many oddities/decorations have@@ -19,11 +19,10 @@ -----------------------------------------------------------------------------  module PprC (-        writeCs,-        pprStringInCStyle+        writeC   ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  -- Cmm stuff import GhcPrelude@@ -32,7 +31,7 @@ import CLabel import ForeignCall import Cmm hiding (pprBBlock)-import PprCmm ()+import PprCmm () -- For Outputable instances import Hoopl.Block import Hoopl.Collections import Hoopl.Graph@@ -44,35 +43,32 @@ import DynFlags import FastString import Outputable-import Platform+import GHC.Platform import UniqSet import UniqFM import Unique import Util  -- The rest+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS import Control.Monad.ST import Data.Bits import Data.Char-import Data.List+import Data.List (intersperse) import Data.Map (Map) import Data.Word import System.IO import qualified Data.Map as Map-import Control.Monad (liftM, ap)+import Control.Monad (ap) import qualified Data.Array.Unsafe as U ( castSTUArray ) import Data.Array.ST  -- -------------------------------------------------------------------------- -- Top level -pprCs :: [RawCmmGroup] -> SDoc-pprCs cmms- = pprCode CStyle (vcat $ map pprC cmms)--writeCs :: DynFlags -> Handle -> [RawCmmGroup] -> IO ()-writeCs dflags handle cmms-  = printForC dflags handle (pprCs cmms)+writeC :: DynFlags -> Handle -> RawCmmGroup -> IO ()+writeC dflags handle cmm = printForC dflags handle (pprC cmm $$ blankLine)  -- -------------------------------------------------------------------------- -- Now do some real work@@ -177,7 +173,7 @@ -- -- It's a reasonable assumption also known as natural alignment. -- Although some architectures have different alignment rules.--- One of known exceptions is m68k (Trac #11395, comment:16) where:+-- One of known exceptions is m68k (#11395, comment:16) where: --   __alignof__(StgWord) == 2, sizeof(StgWord) == 4 -- -- Thus we explicitly increase alignment by using@@ -238,7 +234,7 @@          cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn) -        -- See wiki:Commentary/Compiler/Backends/PprC#Prototypes+        -- See wiki:commentary/compiler/backends/ppr-c#prototypes         fnCall =             case fn of               CmmLit (CmmLabel lbl)@@ -786,7 +782,9 @@         MO_F64_Acosh    -> text "acosh"         MO_F64_Atan     -> text "atan"         MO_F64_Log      -> text "log"+        MO_F64_Log1P    -> text "log1p"         MO_F64_Exp      -> text "exp"+        MO_F64_ExpM1    -> text "expm1"         MO_F64_Sqrt     -> text "sqrt"         MO_F64_Fabs     -> text "fabs"         MO_F32_Pwr      -> text "powf"@@ -803,7 +801,9 @@         MO_F32_Acosh    -> text "acoshf"         MO_F32_Atanh    -> text "atanhf"         MO_F32_Log      -> text "logf"+        MO_F32_Log1P    -> text "log1pf"         MO_F32_Exp      -> text "expf"+        MO_F32_ExpM1    -> text "expm1f"         MO_F32_Sqrt     -> text "sqrtf"         MO_F32_Fabs     -> text "fabsf"         MO_ReadBarrier  -> text "load_load_barrier"@@ -813,6 +813,7 @@         MO_Memmove _    -> text "memmove"         MO_Memcmp _     -> text "memcmp"         (MO_BSwap w)    -> ptext (sLit $ bSwapLabel w)+        (MO_BRev w)     -> ptext (sLit $ bRevLabel w)         (MO_PopCnt w)   -> ptext (sLit $ popCntLabel w)         (MO_Pext w)     -> ptext (sLit $ pextLabel w)         (MO_Pdep w)     -> ptext (sLit $ pdepLabel w)@@ -1076,10 +1077,7 @@         <> semi  type TEState = (UniqSet LocalReg, Map CLabel ())-newtype TE a = TE { unTE :: TEState -> (a, TEState) }--instance Functor TE where-      fmap = liftM+newtype TE a = TE { unTE :: TEState -> (a, TEState) } deriving (Functor)  instance Applicative TE where       pure a = TE $ \s -> (a, s)@@ -1225,8 +1223,8 @@ -- --------------------------------------------------------------------- -- print strings as valid C strings -pprStringInCStyle :: [Word8] -> SDoc-pprStringInCStyle s = doubleQuotes (text (concatMap charToC s))+pprStringInCStyle :: ByteString -> SDoc+pprStringInCStyle s = doubleQuotes (text (concatMap charToC (BS.unpack s)))  -- --------------------------------------------------------------------------- -- Initialising static objects with floating-point numbers.  We can't
compiler/cmm/PprCmm.hs view
@@ -41,7 +41,6 @@  import GhcPrelude hiding (succ) -import BlockId () import CLabel import Cmm import CmmUtils@@ -52,7 +51,6 @@ import PprCmmDecl import PprCmmExpr import Util-import PprCore ()  import BasicTypes import Hoopl.Block
compiler/cmm/PprCmmDecl.hs view
@@ -50,8 +50,7 @@ import Data.List import System.IO --- Temp Jan08-import SMRep+import qualified Data.ByteString as BS   pprCmms :: (Outputable info, Outputable g)@@ -95,7 +94,7 @@  pprTop (CmmProc info lbl live graph) -  = vcat [ ppr lbl <> lparen <> rparen <+> text "// " <+> ppr live+  = vcat [ ppr lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live          , nest 8 $ lbrace <+> ppr info $$ rbrace          , nest 4 $ ppr graph          , rbrace ]@@ -121,8 +120,8 @@          , case prof_info of              NoProfilingInfo -> empty              ProfilingInfo ct cd ->-               vcat [ text "type: " <> pprWord8String ct-                    , text "desc: " <> pprWord8String cd ]+               vcat [ text "type: " <> text (show (BS.unpack ct))+                    , text "desc: " <> text (show (BS.unpack cd)) ]          , text "srt: " <> ppr srt ]  instance Outputable ForeignHint where
compiler/cmm/SMRep.hs view
@@ -13,7 +13,7 @@          StgWord, fromStgWord, toStgWord,         StgHalfWord, fromStgHalfWord, toStgHalfWord,-        hALF_WORD_SIZE, hALF_WORD_SIZE_IN_BITS,+        halfWordSize, halfWordSizeInBits,          -- * Closure repesentation         SMRep(..), -- CmmInfo sees the rep; no one else does@@ -41,10 +41,7 @@         aRG_GEN, aRG_GEN_BIG,          -- ** Arrays-        card, cardRoundUp, cardTableSizeB, cardTableSizeW,--        -- * Operations over [Word8] strings that don't belong here-        pprWord8String, stringToWord8s+        card, cardRoundUp, cardTableSizeB, cardTableSizeW     ) where  import GhcPrelude@@ -52,12 +49,12 @@ import BasicTypes( ConTagZ ) import DynFlags import Outputable-import Platform+import GHC.Platform import FastString -import Data.Char( ord ) import Data.Word import Data.Bits+import Data.ByteString (ByteString)  {- ************************************************************************@@ -110,9 +107,8 @@     = case platformWordSize (targetPlatform dflags) of       -- These conversions mean that things like toStgWord (-1)       -- do the right thing-      4 -> StgWord (fromIntegral (fromInteger i :: Word32))-      8 -> StgWord (fromInteger i :: Word64)-      w -> panic ("toStgWord: Unknown platformWordSize: " ++ show w)+      PW4 -> StgWord (fromIntegral (fromInteger i :: Word32))+      PW8 -> StgWord (fromInteger i)  instance Outputable StgWord where     ppr (StgWord i) = integer (toInteger i)@@ -132,18 +128,19 @@     = case platformWordSize (targetPlatform dflags) of       -- These conversions mean that things like toStgHalfWord (-1)       -- do the right thing-      4 -> StgHalfWord (fromIntegral (fromInteger i :: Word16))-      8 -> StgHalfWord (fromInteger i :: Word32)-      w -> panic ("toStgHalfWord: Unknown platformWordSize: " ++ show w)+      PW4 -> StgHalfWord (fromIntegral (fromInteger i :: Word16))+      PW8 -> StgHalfWord (fromInteger i :: Word32)  instance Outputable StgHalfWord where     ppr (StgHalfWord w) = integer (toInteger w) -hALF_WORD_SIZE :: DynFlags -> ByteOff-hALF_WORD_SIZE dflags = platformWordSize (targetPlatform dflags) `shiftR` 1-hALF_WORD_SIZE_IN_BITS :: DynFlags -> Int-hALF_WORD_SIZE_IN_BITS dflags = platformWordSize (targetPlatform dflags) `shiftL` 2+-- | Half word size in bytes+halfWordSize :: DynFlags -> ByteOff+halfWordSize dflags = platformWordSizeInBytes (targetPlatform dflags) `div` 2 +halfWordSizeInBits :: DynFlags -> Int+halfWordSizeInBits dflags = platformWordSizeInBits (targetPlatform dflags) `div` 2+ {- ************************************************************************ *                                                                      *@@ -195,7 +192,7 @@   | BlackHole   | IndStatic -type ConstrDescription = [Word8] -- result of dataConIdentity+type ConstrDescription = ByteString -- result of dataConIdentity type FunArity          = Int type SelectorOffset    = Int @@ -564,11 +561,3 @@ pprTypeInfo Thunk     = text "Thunk" pprTypeInfo BlackHole = text "BlackHole" pprTypeInfo IndStatic = text "IndStatic"---- XXX Does not belong here!!-stringToWord8s :: String -> [Word8]-stringToWord8s s = map (fromIntegral . ord) s--pprWord8String :: [Word8] -> SDoc--- Debug printing.  Not very clever right now.-pprWord8String ws = text (show ws)
− compiler/codeGen/CgUtils.hs 
@@ -1,182 +0,0 @@-{-# LANGUAGE GADTs #-}------------------------------------------------------------------------------------- Code generator utilities; mostly monadic------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module CgUtils ( fixStgRegisters ) where--import GhcPrelude--import CodeGen.Platform-import Cmm-import Hoopl.Block-import Hoopl.Graph-import CmmUtils-import CLabel-import DynFlags-import Outputable---- -------------------------------------------------------------------------------- Information about global registers--baseRegOffset :: DynFlags -> GlobalReg -> Int--baseRegOffset dflags (VanillaReg 1 _)    = oFFSET_StgRegTable_rR1 dflags-baseRegOffset dflags (VanillaReg 2 _)    = oFFSET_StgRegTable_rR2 dflags-baseRegOffset dflags (VanillaReg 3 _)    = oFFSET_StgRegTable_rR3 dflags-baseRegOffset dflags (VanillaReg 4 _)    = oFFSET_StgRegTable_rR4 dflags-baseRegOffset dflags (VanillaReg 5 _)    = oFFSET_StgRegTable_rR5 dflags-baseRegOffset dflags (VanillaReg 6 _)    = oFFSET_StgRegTable_rR6 dflags-baseRegOffset dflags (VanillaReg 7 _)    = oFFSET_StgRegTable_rR7 dflags-baseRegOffset dflags (VanillaReg 8 _)    = oFFSET_StgRegTable_rR8 dflags-baseRegOffset dflags (VanillaReg 9 _)    = oFFSET_StgRegTable_rR9 dflags-baseRegOffset dflags (VanillaReg 10 _)   = oFFSET_StgRegTable_rR10 dflags-baseRegOffset _      (VanillaReg n _)    = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")")-baseRegOffset dflags (FloatReg  1)       = oFFSET_StgRegTable_rF1 dflags-baseRegOffset dflags (FloatReg  2)       = oFFSET_StgRegTable_rF2 dflags-baseRegOffset dflags (FloatReg  3)       = oFFSET_StgRegTable_rF3 dflags-baseRegOffset dflags (FloatReg  4)       = oFFSET_StgRegTable_rF4 dflags-baseRegOffset dflags (FloatReg  5)       = oFFSET_StgRegTable_rF5 dflags-baseRegOffset dflags (FloatReg  6)       = oFFSET_StgRegTable_rF6 dflags-baseRegOffset _      (FloatReg  n)       = panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")")-baseRegOffset dflags (DoubleReg 1)       = oFFSET_StgRegTable_rD1 dflags-baseRegOffset dflags (DoubleReg 2)       = oFFSET_StgRegTable_rD2 dflags-baseRegOffset dflags (DoubleReg 3)       = oFFSET_StgRegTable_rD3 dflags-baseRegOffset dflags (DoubleReg 4)       = oFFSET_StgRegTable_rD4 dflags-baseRegOffset dflags (DoubleReg 5)       = oFFSET_StgRegTable_rD5 dflags-baseRegOffset dflags (DoubleReg 6)       = oFFSET_StgRegTable_rD6 dflags-baseRegOffset _      (DoubleReg n)       = panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")")-baseRegOffset dflags (XmmReg 1)          = oFFSET_StgRegTable_rXMM1 dflags-baseRegOffset dflags (XmmReg 2)          = oFFSET_StgRegTable_rXMM2 dflags-baseRegOffset dflags (XmmReg 3)          = oFFSET_StgRegTable_rXMM3 dflags-baseRegOffset dflags (XmmReg 4)          = oFFSET_StgRegTable_rXMM4 dflags-baseRegOffset dflags (XmmReg 5)          = oFFSET_StgRegTable_rXMM5 dflags-baseRegOffset dflags (XmmReg 6)          = oFFSET_StgRegTable_rXMM6 dflags-baseRegOffset _      (XmmReg n)          = panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")")-baseRegOffset dflags (YmmReg 1)          = oFFSET_StgRegTable_rYMM1 dflags-baseRegOffset dflags (YmmReg 2)          = oFFSET_StgRegTable_rYMM2 dflags-baseRegOffset dflags (YmmReg 3)          = oFFSET_StgRegTable_rYMM3 dflags-baseRegOffset dflags (YmmReg 4)          = oFFSET_StgRegTable_rYMM4 dflags-baseRegOffset dflags (YmmReg 5)          = oFFSET_StgRegTable_rYMM5 dflags-baseRegOffset dflags (YmmReg 6)          = oFFSET_StgRegTable_rYMM6 dflags-baseRegOffset _      (YmmReg n)          = panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")")-baseRegOffset dflags (ZmmReg 1)          = oFFSET_StgRegTable_rZMM1 dflags-baseRegOffset dflags (ZmmReg 2)          = oFFSET_StgRegTable_rZMM2 dflags-baseRegOffset dflags (ZmmReg 3)          = oFFSET_StgRegTable_rZMM3 dflags-baseRegOffset dflags (ZmmReg 4)          = oFFSET_StgRegTable_rZMM4 dflags-baseRegOffset dflags (ZmmReg 5)          = oFFSET_StgRegTable_rZMM5 dflags-baseRegOffset dflags (ZmmReg 6)          = oFFSET_StgRegTable_rZMM6 dflags-baseRegOffset _      (ZmmReg n)          = panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")")-baseRegOffset dflags Sp                  = oFFSET_StgRegTable_rSp dflags-baseRegOffset dflags SpLim               = oFFSET_StgRegTable_rSpLim dflags-baseRegOffset dflags (LongReg 1)         = oFFSET_StgRegTable_rL1 dflags-baseRegOffset _      (LongReg n)         = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")")-baseRegOffset dflags Hp                  = oFFSET_StgRegTable_rHp dflags-baseRegOffset dflags HpLim               = oFFSET_StgRegTable_rHpLim dflags-baseRegOffset dflags CCCS                = oFFSET_StgRegTable_rCCCS dflags-baseRegOffset dflags CurrentTSO          = oFFSET_StgRegTable_rCurrentTSO dflags-baseRegOffset dflags CurrentNursery      = oFFSET_StgRegTable_rCurrentNursery dflags-baseRegOffset dflags HpAlloc             = oFFSET_StgRegTable_rHpAlloc dflags-baseRegOffset dflags EagerBlackholeInfo  = oFFSET_stgEagerBlackholeInfo dflags-baseRegOffset dflags GCEnter1            = oFFSET_stgGCEnter1 dflags-baseRegOffset dflags GCFun               = oFFSET_stgGCFun dflags-baseRegOffset _      BaseReg             = panic "CgUtils.baseRegOffset:BaseReg"-baseRegOffset _      PicBaseReg          = panic "CgUtils.baseRegOffset:PicBaseReg"-baseRegOffset _      MachSp              = panic "CgUtils.baseRegOffset:MachSp"-baseRegOffset _      UnwindReturnReg     = panic "CgUtils.baseRegOffset:UnwindReturnReg"----- ----------------------------------------------------------------------------------- STG/Cmm GlobalReg------ --------------------------------------------------------------------------------- | We map STG registers onto appropriate CmmExprs.  Either they map--- to real machine registers or stored as offsets from BaseReg.  Given--- a GlobalReg, get_GlobalReg_addr always produces the--- register table address for it.-get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr-get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0-get_GlobalReg_addr dflags mid-    = get_Regtable_addr_from_offset dflags-                                    (globalRegType dflags mid) (baseRegOffset dflags mid)---- Calculate a literal representing an offset into the register table.--- Used when we don't have an actual BaseReg to offset from.-regTableOffset :: DynFlags -> Int -> CmmExpr-regTableOffset dflags n =-  CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))--get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr-get_Regtable_addr_from_offset dflags _ offset =-    if haveRegBase (targetPlatform dflags)-    then CmmRegOff baseReg offset-    else regTableOffset dflags offset---- | Fixup global registers so that they assign to locations within the--- RegTable if they aren't pinned for the current target.-fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl-fixStgRegisters _ top@(CmmData _ _) = top--fixStgRegisters dflags (CmmProc info lbl live graph) =-  let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock dflags)) graph-  in CmmProc info lbl live graph'--fixStgRegBlock :: DynFlags -> Block CmmNode e x -> Block CmmNode e x-fixStgRegBlock dflags block = mapBlock (fixStgRegStmt dflags) block--fixStgRegStmt :: DynFlags -> CmmNode e x -> CmmNode e x-fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt-  where-    platform = targetPlatform dflags--    fixAssign stmt =-      case stmt of-        CmmAssign (CmmGlobal reg) src-          -- MachSp isn't an STG register; it's merely here for tracking unwind-          -- information-          | reg == MachSp -> stmt-          | otherwise ->-            let baseAddr = get_GlobalReg_addr dflags reg-            in case reg `elem` activeStgRegs (targetPlatform dflags) of-                True  -> CmmAssign (CmmGlobal reg) src-                False -> CmmStore baseAddr src-        other_stmt -> other_stmt--    fixExpr expr = case expr of-        -- MachSp isn't an STG; it's merely here for tracking unwind information-        CmmReg (CmmGlobal MachSp) -> expr-        CmmReg (CmmGlobal reg) ->-            -- Replace register leaves with appropriate StixTrees for-            -- the given target.  MagicIds which map to a reg on this-            -- arch are left unchanged.  For the rest, BaseReg is taken-            -- to mean the address of the reg table in MainCapability,-            -- and for all others we generate an indirection to its-            -- location in the register table.-            case reg `elem` activeStgRegs platform of-                True  -> expr-                False ->-                    let baseAddr = get_GlobalReg_addr dflags reg-                    in case reg of-                        BaseReg -> baseAddr-                        _other  -> CmmLoad baseAddr (globalRegType dflags reg)--        CmmRegOff (CmmGlobal reg) offset ->-            -- RegOf leaves are just a shorthand form. If the reg maps-            -- to a real reg, we keep the shorthand, otherwise, we just-            -- expand it and defer to the above code.-            case reg `elem` activeStgRegs platform of-                True  -> expr-                False -> CmmMachOp (MO_Add (wordWidth dflags)) [-                                    fixExpr (CmmReg (CmmGlobal reg)),-                                    CmmLit (CmmInt (fromIntegral offset)-                                                   (wordWidth dflags))]--        other_expr -> other_expr-
− compiler/codeGen/CodeGen/Platform.hs 
@@ -1,107 +0,0 @@--module CodeGen.Platform-       (callerSaves, activeStgRegs, haveRegBase, globalRegMaybe, freeReg)-       where--import GhcPrelude--import CmmExpr-import Platform-import Reg--import qualified CodeGen.Platform.ARM        as ARM-import qualified CodeGen.Platform.ARM64      as ARM64-import qualified CodeGen.Platform.PPC        as PPC-import qualified CodeGen.Platform.SPARC      as SPARC-import qualified CodeGen.Platform.X86        as X86-import qualified CodeGen.Platform.X86_64     as X86_64-import qualified CodeGen.Platform.NoRegs     as NoRegs---- | Returns 'True' if this global register is stored in a caller-saves--- machine register.--callerSaves :: Platform -> GlobalReg -> Bool-callerSaves platform- | platformUnregisterised platform = NoRegs.callerSaves- | otherwise- = case platformArch platform of-   ArchX86    -> X86.callerSaves-   ArchX86_64 -> X86_64.callerSaves-   ArchSPARC  -> SPARC.callerSaves-   ArchARM {} -> ARM.callerSaves-   ArchARM64  -> ARM64.callerSaves-   arch-    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->-        PPC.callerSaves--    | otherwise -> NoRegs.callerSaves---- | Here is where the STG register map is defined for each target arch.--- The order matters (for the llvm backend anyway)! We must make sure to--- maintain the order here with the order used in the LLVM calling conventions.--- Note that also, this isn't all registers, just the ones that are currently--- possbily mapped to real registers.-activeStgRegs :: Platform -> [GlobalReg]-activeStgRegs platform- | platformUnregisterised platform = NoRegs.activeStgRegs- | otherwise- = case platformArch platform of-   ArchX86    -> X86.activeStgRegs-   ArchX86_64 -> X86_64.activeStgRegs-   ArchSPARC  -> SPARC.activeStgRegs-   ArchARM {} -> ARM.activeStgRegs-   ArchARM64  -> ARM64.activeStgRegs-   arch-    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->-        PPC.activeStgRegs--    | otherwise -> NoRegs.activeStgRegs--haveRegBase :: Platform -> Bool-haveRegBase platform- | platformUnregisterised platform = NoRegs.haveRegBase- | otherwise- = case platformArch platform of-   ArchX86    -> X86.haveRegBase-   ArchX86_64 -> X86_64.haveRegBase-   ArchSPARC  -> SPARC.haveRegBase-   ArchARM {} -> ARM.haveRegBase-   ArchARM64  -> ARM64.haveRegBase-   arch-    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->-        PPC.haveRegBase--    | otherwise -> NoRegs.haveRegBase--globalRegMaybe :: Platform -> GlobalReg -> Maybe RealReg-globalRegMaybe platform- | platformUnregisterised platform = NoRegs.globalRegMaybe- | otherwise- = case platformArch platform of-   ArchX86    -> X86.globalRegMaybe-   ArchX86_64 -> X86_64.globalRegMaybe-   ArchSPARC  -> SPARC.globalRegMaybe-   ArchARM {} -> ARM.globalRegMaybe-   ArchARM64  -> ARM64.globalRegMaybe-   arch-    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->-        PPC.globalRegMaybe--    | otherwise -> NoRegs.globalRegMaybe--freeReg :: Platform -> RegNo -> Bool-freeReg platform- | platformUnregisterised platform = NoRegs.freeReg- | otherwise- = case platformArch platform of-   ArchX86    -> X86.freeReg-   ArchX86_64 -> X86_64.freeReg-   ArchSPARC  -> SPARC.freeReg-   ArchARM {} -> ARM.freeReg-   ArchARM64  -> ARM64.freeReg-   arch-    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->-        PPC.freeReg--    | otherwise -> NoRegs.freeReg-
− compiler/codeGen/CodeGen/Platform/ARM.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE CPP #-}--module CodeGen.Platform.ARM where--import GhcPrelude--#define MACHREGS_NO_REGS 0-#define MACHREGS_arm 1-#include "../../../../includes/CodeGen.Platform.hs"-
− compiler/codeGen/CodeGen/Platform/ARM64.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE CPP #-}--module CodeGen.Platform.ARM64 where--import GhcPrelude--#define MACHREGS_NO_REGS 0-#define MACHREGS_aarch64 1-#include "../../../../includes/CodeGen.Platform.hs"-
− compiler/codeGen/CodeGen/Platform/NoRegs.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE CPP #-}--module CodeGen.Platform.NoRegs where--import GhcPrelude--#define MACHREGS_NO_REGS 1-#include "../../../../includes/CodeGen.Platform.hs"-
− compiler/codeGen/CodeGen/Platform/PPC.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE CPP #-}--module CodeGen.Platform.PPC where--import GhcPrelude--#define MACHREGS_NO_REGS 0-#define MACHREGS_powerpc 1-#include "../../../../includes/CodeGen.Platform.hs"-
− compiler/codeGen/CodeGen/Platform/SPARC.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE CPP #-}--module CodeGen.Platform.SPARC where--import GhcPrelude--#define MACHREGS_NO_REGS 0-#define MACHREGS_sparc 1-#include "../../../../includes/CodeGen.Platform.hs"-
− compiler/codeGen/CodeGen/Platform/X86.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE CPP #-}--module CodeGen.Platform.X86 where--import GhcPrelude--#define MACHREGS_NO_REGS 0-#define MACHREGS_i386 1-#include "../../../../includes/CodeGen.Platform.hs"-
− compiler/codeGen/CodeGen/Platform/X86_64.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE CPP #-}--module CodeGen.Platform.X86_64 where--import GhcPrelude--#define MACHREGS_NO_REGS 0-#define MACHREGS_x86_64 1-#include "../../../../includes/CodeGen.Platform.hs"-
− compiler/codeGen/StgCmm.hs 
@@ -1,251 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}------------------------------------------------------------------------------------- Stg to C-- code generation------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module StgCmm ( codeGen ) where--#include "GhclibHsVersions.h"--import GhcPrelude as Prelude--import StgCmmProf (initCostCentres, ldvEnter)-import StgCmmMonad-import StgCmmEnv-import StgCmmBind-import StgCmmCon-import StgCmmLayout-import StgCmmUtils-import StgCmmClosure-import StgCmmHpc-import StgCmmTicky--import Cmm-import CmmUtils-import CLabel--import StgSyn-import DynFlags--import HscTypes-import CostCentre-import Id-import IdInfo-import RepType-import DataCon-import Name-import TyCon-import Module-import Outputable-import Stream-import BasicTypes-import VarSet ( isEmptyDVarSet )--import OrdList-import MkGraph--import qualified Data.ByteString as BS-import Data.IORef-import Control.Monad (when,void)-import Util--codeGen :: DynFlags-        -> Module-        -> [TyCon]-        -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.-        -> [CgStgTopBinding]           -- Bindings to convert-        -> HpcInfo-        -> Stream IO CmmGroup ()       -- Output as a stream, so codegen can-                                       -- be interleaved with output--codeGen dflags this_mod data_tycons-        cost_centre_info stg_binds hpc_info-  = do  {     -- cg: run the code generator, and yield the resulting CmmGroup-              -- Using an IORef to store the state is a bit crude, but otherwise-              -- we would need to add a state monad layer.-        ; cgref <- liftIO $ newIORef =<< initC-        ; let cg :: FCode () -> Stream IO CmmGroup ()-              cg fcode = do-                cmm <- liftIO $ do-                         st <- readIORef cgref-                         let (a,st') = runC dflags this_mod st (getCmm fcode)--                         -- NB. stub-out cgs_tops and cgs_stmts.  This fixes-                         -- a big space leak.  DO NOT REMOVE!-                         writeIORef cgref $! st'{ cgs_tops = nilOL,-                                                  cgs_stmts = mkNop }-                         return a-                yield cmm--               -- Note [codegen-split-init] the cmm_init block must come-               -- FIRST.  This is because when -split-objs is on we need to-               -- combine this block with its initialisation routines; see-               -- Note [pipeline-split-init].-        ; cg (mkModuleInit cost_centre_info this_mod hpc_info)--        ; mapM_ (cg . cgTopBinding dflags) stg_binds--                -- Put datatype_stuff after code_stuff, because the-                -- datatype closure table (for enumeration types) to-                -- (say) PrelBase_True_closure, which is defined in-                -- code_stuff-        ; let do_tycon tycon = do-                -- Generate a table of static closures for an-                -- enumeration type Note that the closure pointers are-                -- tagged.-                 when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)-                 mapM_ (cg . cgDataCon) (tyConDataCons tycon)--        ; mapM_ do_tycon data_tycons-        }--------------------------------------------------------------------      Top-level bindings------------------------------------------------------------------{- 'cgTopBinding' is only used for top-level bindings, since they need-to be allocated statically (not in the heap) and need to be labelled.-No unboxed bindings can happen at top level.--In the code below, the static bindings are accumulated in the-@MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.-This is so that we can write the top level processing in a compositional-style, with the increasing static environment being plumbed as a state-variable. -}--cgTopBinding :: DynFlags -> CgStgTopBinding -> FCode ()-cgTopBinding dflags (StgTopLifted (StgNonRec id rhs))-  = do  { id' <- maybeExternaliseId dflags id-        ; let (info, fcode) = cgTopRhs dflags NonRecursive id' rhs-        ; fcode-        ; addBindC info -- Add the *un-externalised* Id to the envt,-                        -- so we find it when we look up occurrences-        }--cgTopBinding dflags (StgTopLifted (StgRec pairs))-  = do  { let (bndrs, rhss) = unzip pairs-        ; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs-        ; let pairs' = zip bndrs' rhss-              r = unzipWith (cgTopRhs dflags Recursive) pairs'-              (infos, fcodes) = unzip r-        ; addBindsC infos-        ; sequence_ fcodes-        }--cgTopBinding dflags (StgTopStringLit id str)-  = do  { id' <- maybeExternaliseId dflags id-        ; let label = mkBytesLabel (idName id')-        ; let (lit, decl) = mkByteStringCLit label (BS.unpack str)-        ; emitDecl decl-        ; addBindC (litIdInfo dflags id' mkLFStringLit lit)-        }--cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())-        -- The Id is passed along for setting up a binding...-        -- It's already been externalised if necessary--cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)-  = cgTopRhsCon dflags bndr con (assertNonVoidStgArgs args)-      -- con args are always non-void,-      -- see Note [Post-unarisation invariants] in UnariseStg--cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body)-  = ASSERT(isEmptyDVarSet fvs)    -- There should be no free variables-    cgTopRhsClosure dflags rec bndr cc upd_flag args body---------------------------------------------------------------------      Module initialisation code------------------------------------------------------------------mkModuleInit-        :: CollectedCCs         -- cost centre info-        -> Module-        -> HpcInfo-        -> FCode ()--mkModuleInit cost_centre_info this_mod hpc_info-  = do  { initHpc this_mod hpc_info-        ; initCostCentres cost_centre_info-        }---------------------------------------------------------------------      Generating static stuff for algebraic data types-------------------------------------------------------------------cgEnumerationTyCon :: TyCon -> FCode ()-cgEnumerationTyCon tycon-  = do dflags <- getDynFlags-       emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)-             [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)-                           (tagForCon dflags con)-             | con <- tyConDataCons tycon]---cgDataCon :: DataCon -> FCode ()--- Generate the entry code, info tables, and (for niladic constructor)--- the static closure, for a constructor.-cgDataCon data_con-  = do  { dflags <- getDynFlags-        ; let-            (tot_wds, --  #ptr_wds + #nonptr_wds-             ptr_wds) --  #ptr_wds-              = mkVirtConstrSizes dflags arg_reps--            nonptr_wds   = tot_wds - ptr_wds--            dyn_info_tbl =-              mkDataConInfoTable dflags data_con False ptr_wds nonptr_wds--            -- We're generating info tables, so we don't know and care about-            -- what the actual arguments are. Using () here as the place holder.-            arg_reps :: [NonVoid PrimRep]-            arg_reps = [ NonVoid rep_ty-                       | ty <- dataConRepArgTys data_con-                       , rep_ty <- typePrimRep ty-                       , not (isVoidRep rep_ty) ]--        ; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $-            -- NB: the closure pointer is assumed *untagged* on-            -- entry to a constructor.  If the pointer is tagged,-            -- then we should not be entering it.  This assumption-            -- is used in ldvEnter and when tagging the pointer to-            -- return it.-            -- NB 2: We don't set CC when entering data (WDP 94/06)-            do { tickyEnterDynCon-               ; ldvEnter (CmmReg nodeReg)-               ; tickyReturnOldCon (length arg_reps)-               ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) (tagForCon dflags data_con)]-               }-                    -- The case continuation code expects a tagged pointer-        }--------------------------------------------------------------------      Stuff to support splitting------------------------------------------------------------------maybeExternaliseId :: DynFlags -> Id -> FCode Id-maybeExternaliseId dflags id-  | gopt Opt_SplitObjs dflags,  -- See Note [Externalise when splitting]-                                -- in StgCmmMonad-    isInternalName name = do { mod <- getModuleName-                             ; return (setIdName id (externalise mod)) }-  | otherwise           = return id-  where-    externalise mod = mkExternalName uniq mod new_occ loc-    name    = idName id-    uniq    = nameUnique name-    new_occ = mkLocalOcc uniq (nameOccName name)-    loc     = nameSrcSpan name-        -- We want to conjure up a name that can't clash with any-        -- existing name.  So we generate-        --      Mod_$L243foo-        -- where 243 is the unique.
− compiler/codeGen/StgCmmArgRep.hs 
@@ -1,158 +0,0 @@------------------------------------------------------------------------------------ Argument representations used in StgCmmLayout.------ (c) The University of Glasgow 2013-----------------------------------------------------------------------------------module StgCmmArgRep (-        ArgRep(..), toArgRep, argRepSizeW,--        argRepString, isNonV, idArgRep,--        slowCallPattern,--        ) where--import GhcPrelude--import StgCmmClosure    ( idPrimRep )--import SMRep            ( WordOff )-import Id               ( Id )-import TyCon            ( PrimRep(..), primElemRepSizeB )-import BasicTypes       ( RepArity )-import Constants        ( wORD64_SIZE )-import DynFlags--import Outputable-import FastString---- I extricated this code as this new module in order to avoid a--- cyclic dependency between StgCmmLayout and StgCmmTicky.------ NSF 18 Feb 2013------------------------------------------------------------------------------      Classifying arguments: ArgRep------------------------------------------------------------------------------ ArgRep is re-exported by StgCmmLayout, but only for use in the--- byte-code generator which also needs to know about the--- classification of arguments.--data ArgRep = P   -- GC Ptr-            | N   -- Word-sized non-ptr-            | L   -- 64-bit non-ptr (long)-            | V   -- Void-            | F   -- Float-            | D   -- Double-            | V16 -- 16-byte (128-bit) vectors of Float/Double/Int8/Word32/etc.-            | V32 -- 32-byte (256-bit) vectors of Float/Double/Int8/Word32/etc.-            | V64 -- 64-byte (512-bit) vectors of Float/Double/Int8/Word32/etc.-instance Outputable ArgRep where ppr = text . argRepString--argRepString :: ArgRep -> String-argRepString P = "P"-argRepString N = "N"-argRepString L = "L"-argRepString V = "V"-argRepString F = "F"-argRepString D = "D"-argRepString V16 = "V16"-argRepString V32 = "V32"-argRepString V64 = "V64"--toArgRep :: PrimRep -> ArgRep-toArgRep VoidRep           = V-toArgRep LiftedRep         = P-toArgRep UnliftedRep       = P-toArgRep IntRep            = N-toArgRep WordRep           = N-toArgRep Int8Rep           = N  -- Gets widened to native word width for calls-toArgRep Word8Rep          = N  -- Gets widened to native word width for calls-toArgRep Int16Rep          = N  -- Gets widened to native word width for calls-toArgRep Word16Rep         = N  -- Gets widened to native word width for calls-toArgRep AddrRep           = N-toArgRep Int64Rep          = L-toArgRep Word64Rep         = L-toArgRep FloatRep          = F-toArgRep DoubleRep         = D-toArgRep (VecRep len elem) = case len*primElemRepSizeB elem of-                               16 -> V16-                               32 -> V32-                               64 -> V64-                               _  -> error "toArgRep: bad vector primrep"--isNonV :: ArgRep -> Bool-isNonV V = False-isNonV _ = True--argRepSizeW :: DynFlags -> ArgRep -> WordOff                -- Size in words-argRepSizeW _      N   = 1-argRepSizeW _      P   = 1-argRepSizeW _      F   = 1-argRepSizeW dflags L   = wORD64_SIZE        `quot` wORD_SIZE dflags-argRepSizeW dflags D   = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags-argRepSizeW _      V   = 0-argRepSizeW dflags V16 = 16                 `quot` wORD_SIZE dflags-argRepSizeW dflags V32 = 32                 `quot` wORD_SIZE dflags-argRepSizeW dflags V64 = 64                 `quot` wORD_SIZE dflags--idArgRep :: Id -> ArgRep-idArgRep = toArgRep . idPrimRep---- This list of argument patterns should be kept in sync with at least--- the following:------  * StgCmmLayout.stdPattern maybe to some degree?------  * the RTS_RET(stg_ap_*) and RTS_FUN_DECL(stg_ap_*_fast)---  declarations in includes/stg/MiscClosures.h------  * the SLOW_CALL_*_ctr declarations in includes/stg/Ticky.h,------  * the TICK_SLOW_CALL_*() #defines in includes/Cmm.h,------  * the PR_CTR(SLOW_CALL_*_ctr) calls in rts/Ticky.c,------  * and the SymI_HasProto(stg_ap_*_{ret,info,fast}) calls and---  SymI_HasProto(SLOW_CALL_*_ctr) calls in rts/Linker.c------ There may be more places that I haven't found; I merely igrep'd for--- pppppp and excluded things that seemed ghci-specific.------ Also, it seems at the moment that ticky counters with void--- arguments will never be bumped, but I'm still declaring those--- counters, defensively.------ NSF 6 Mar 2013--slowCallPattern :: [ArgRep] -> (FastString, RepArity)--- Returns the generic apply function and arity------ The first batch of cases match (some) specialised entries--- The last group deals exhaustively with the cases for the first argument---   (and the zero-argument case)------ In 99% of cases this function will match *all* the arguments in one batch--slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6)-slowCallPattern (P: P: P: P: P: _)    = (fsLit "stg_ap_ppppp", 5)-slowCallPattern (P: P: P: P: _)       = (fsLit "stg_ap_pppp", 4)-slowCallPattern (P: P: P: V: _)       = (fsLit "stg_ap_pppv", 4)-slowCallPattern (P: P: P: _)          = (fsLit "stg_ap_ppp", 3)-slowCallPattern (P: P: V: _)          = (fsLit "stg_ap_ppv", 3)-slowCallPattern (P: P: _)             = (fsLit "stg_ap_pp", 2)-slowCallPattern (P: V: _)             = (fsLit "stg_ap_pv", 2)-slowCallPattern (P: _)                = (fsLit "stg_ap_p", 1)-slowCallPattern (V: _)                = (fsLit "stg_ap_v", 1)-slowCallPattern (N: _)                = (fsLit "stg_ap_n", 1)-slowCallPattern (F: _)                = (fsLit "stg_ap_f", 1)-slowCallPattern (D: _)                = (fsLit "stg_ap_d", 1)-slowCallPattern (L: _)                = (fsLit "stg_ap_l", 1)-slowCallPattern (V16: _)              = (fsLit "stg_ap_v16", 1)-slowCallPattern (V32: _)              = (fsLit "stg_ap_v32", 1)-slowCallPattern (V64: _)              = (fsLit "stg_ap_v64", 1)-slowCallPattern []                    = (fsLit "stg_ap_0", 0)
− compiler/codeGen/StgCmmBind.hs 
@@ -1,752 +0,0 @@------------------------------------------------------------------------------------ Stg to C-- code generation: bindings------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module StgCmmBind (-        cgTopRhsClosure,-        cgBind,-        emitBlackHoleCode,-        pushUpdateFrame, emitUpdateFrame-  ) where--import GhcPrelude hiding ((<*>))--import StgCmmExpr-import StgCmmMonad-import StgCmmEnv-import StgCmmCon-import StgCmmHeap-import StgCmmProf (ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk,-                   initUpdFrameProf)-import StgCmmTicky-import StgCmmLayout-import StgCmmUtils-import StgCmmClosure-import StgCmmForeign    (emitPrimCall)--import MkGraph-import CoreSyn          ( AltCon(..), tickishIsCode )-import BlockId-import SMRep-import Cmm-import CmmInfo-import CmmUtils-import CLabel-import StgSyn-import CostCentre-import Id-import IdInfo-import Name-import Module-import ListSetOps-import Util-import VarSet-import BasicTypes-import Outputable-import FastString-import DynFlags--import Control.Monad-----------------------------------------------------------------------------              Top-level bindings----------------------------------------------------------------------------- For closures bound at top level, allocate in static space.--- They should have no free variables.--cgTopRhsClosure :: DynFlags-                -> RecFlag              -- member of a recursive group?-                -> Id-                -> CostCentreStack      -- Optional cost centre annotation-                -> UpdateFlag-                -> [Id]                 -- Args-                -> CgStgExpr-                -> (CgIdInfo, FCode ())--cgTopRhsClosure dflags rec id ccs upd_flag args body =-  let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)-      cg_id_info    = litIdInfo dflags id lf_info (CmmLabel closure_label)-      lf_info       = mkClosureLFInfo dflags id TopLevel [] upd_flag args-  in (cg_id_info, gen_code dflags lf_info closure_label)-  where-  -- special case for a indirection (f = g).  We create an IND_STATIC-  -- closure pointing directly to the indirectee.  This is exactly-  -- what the CAF will eventually evaluate to anyway, we're just-  -- shortcutting the whole process, and generating a lot less code-  -- (#7308)-  ---  -- Note: we omit the optimisation when this binding is part of a-  -- recursive group, because the optimisation would inhibit the black-  -- hole detection from working in that case.  Test-  -- concurrent/should_run/4030 fails, for instance.-  ---  gen_code dflags _ closure_label-    | StgApp f [] <- body, null args, isNonRec rec-    = do-         cg_info <- getCgIdInfo f-         let closure_rep   = mkStaticClosureFields dflags-                                    indStaticInfoTable ccs MayHaveCafRefs-                                    [unLit (idInfoToAmode cg_info)]-         emitDataLits closure_label closure_rep-         return ()--  gen_code dflags lf_info _closure_label-   = do { let name = idName id-        ; mod_name <- getModuleName-        ; let descr         = closureDescription dflags mod_name name-              closure_info  = mkClosureInfo dflags True id lf_info 0 0 descr--        -- We don't generate the static closure here, because we might-        -- want to add references to static closures to it later.  The-        -- static closure is generated by CmmBuildInfoTables.updInfoSRTs,-        -- See Note [SRTs], specifically the [FUN] optimisation.--        ; let fv_details :: [(NonVoid Id, ByteOff)]-              header = if isLFThunk lf_info then ThunkHeader else StdHeader-              (_, _, fv_details) = mkVirtHeapOffsets dflags header []-        -- Don't drop the non-void args until the closure info has been made-        ; forkClosureBody (closureCodeBody True id closure_info ccs-                                (nonVoidIds args) (length args) body fv_details)--        ; return () }--  unLit (CmmLit l) = l-  unLit _ = panic "unLit"-----------------------------------------------------------------------------              Non-top-level bindings---------------------------------------------------------------------------cgBind :: CgStgBinding -> FCode ()-cgBind (StgNonRec name rhs)-  = do  { (info, fcode) <- cgRhs name rhs-        ; addBindC info-        ; init <- fcode-        ; emit init }-        -- init cannot be used in body, so slightly better to sink it eagerly--cgBind (StgRec pairs)-  = do  {  r <- sequence $ unzipWith cgRhs pairs-        ;  let (id_infos, fcodes) = unzip r-        ;  addBindsC id_infos-        ;  (inits, body) <- getCodeR $ sequence fcodes-        ;  emit (catAGraphs inits <*> body) }--{- Note [cgBind rec]--   Recursive let-bindings are tricky.-   Consider the following pseudocode:--     let x = \_ ->  ... y ...-         y = \_ ->  ... z ...-         z = \_ ->  ... x ...-     in ...--   For each binding, we need to allocate a closure, and each closure must-   capture the address of the other closures.-   We want to generate the following C-- code:-     // Initialization Code-     x = hp - 24; // heap address of x's closure-     y = hp - 40; // heap address of x's closure-     z = hp - 64; // heap address of x's closure-     // allocate and initialize x-     m[hp-8]   = ...-     m[hp-16]  = y       // the closure for x captures y-     m[hp-24] = x_info;-     // allocate and initialize y-     m[hp-32] = z;       // the closure for y captures z-     m[hp-40] = y_info;-     // allocate and initialize z-     ...--   For each closure, we must generate not only the code to allocate and-   initialize the closure itself, but also some initialization Code that-   sets a variable holding the closure pointer.--   We could generate a pair of the (init code, body code), but since-   the bindings are recursive we also have to initialise the-   environment with the CgIdInfo for all the bindings before compiling-   anything.  So we do this in 3 stages:--     1. collect all the CgIdInfos and initialise the environment-     2. compile each binding into (init, body) code-     3. emit all the inits, and then all the bodies--   We'd rather not have separate functions to do steps 1 and 2 for-   each binding, since in pratice they share a lot of code.  So we-   have just one function, cgRhs, that returns a pair of the CgIdInfo-   for step 1, and a monadic computation to generate the code in step-   2.--   The alternative to separating things in this way is to use a-   fixpoint.  That's what we used to do, but it introduces a-   maintenance nightmare because there is a subtle dependency on not-   being too strict everywhere.  Doing things this way means that the-   FCode monad can be strict, for example.- -}--cgRhs :: Id-      -> CgStgRhs-      -> FCode (-                 CgIdInfo         -- The info for this binding-               , FCode CmmAGraph  -- A computation which will generate the-                                  -- code for the binding, and return an-                                  -- assignent of the form "x = Hp - n"-                                  -- (see above)-               )--cgRhs id (StgRhsCon cc con args)-  = withNewTickyCounterCon (idName id) $-    buildDynCon id True cc con (assertNonVoidStgArgs args)-      -- con args are always non-void,-      -- see Note [Post-unarisation invariants] in UnariseStg--{- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -}-cgRhs id (StgRhsClosure fvs cc upd_flag args body)-  = do dflags <- getDynFlags-       mkRhsClosure dflags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body-----------------------------------------------------------------------------              Non-constructor right hand sides---------------------------------------------------------------------------mkRhsClosure :: DynFlags -> Id -> CostCentreStack-             -> [NonVoid Id]                    -- Free vars-             -> UpdateFlag-             -> [Id]                            -- Args-             -> CgStgExpr-             -> FCode (CgIdInfo, FCode CmmAGraph)--{- mkRhsClosure looks for two special forms of the right-hand side:-        a) selector thunks-        b) AP thunks--If neither happens, it just calls mkClosureLFInfo.  You might think-that mkClosureLFInfo should do all this, but it seems wrong for the-latter to look at the structure of an expression--Note [Selectors]-~~~~~~~~~~~~~~~~-We look at the body of the closure to see if it's a selector---turgid,-but nothing deep.  We are looking for a closure of {\em exactly} the-form:--...  = [the_fv] \ u [] ->-         case the_fv of-           con a_1 ... a_n -> a_i--Note [Ap thunks]-~~~~~~~~~~~~~~~~-A more generic AP thunk of the form--        x = [ x_1...x_n ] \.. [] -> x_1 ... x_n--A set of these is compiled statically into the RTS, so we just use-those.  We could extend the idea to thunks where some of the x_i are-global ids (and hence not free variables), but this would entail-generating a larger thunk.  It might be an option for non-optimising-compilation, though.--We only generate an Ap thunk if all the free variables are pointers,-for semi-obvious reasons.---}------------ Note [Selectors] -------------------mkRhsClosure    dflags bndr _cc-                [NonVoid the_fv]                -- Just one free var-                upd_flag                -- Updatable thunk-                []                      -- A thunk-                expr-  | let strip = snd . stripStgTicksTop (not . tickishIsCode)-  , StgCase (StgApp scrutinee [{-no args-}])-         _   -- ignore bndr-         (AlgAlt _)-         [(DataAlt _, params, sel_expr)] <- strip expr-  , StgApp selectee [{-no args-}] <- strip sel_expr-  , the_fv == scrutinee                -- Scrutinee is the only free variable--  , let (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps (assertNonVoidIds params))-                                   -- pattern binders are always non-void,-                                   -- see Note [Post-unarisation invariants] in UnariseStg-  , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee)--  , let offset_into_int = bytesToWordsRoundUp dflags the_offset-                          - fixedHdrSizeW dflags-  , offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough-  = -- NOT TRUE: ASSERT(is_single_constructor)-    -- The simplifier may have statically determined that the single alternative-    -- is the only possible case and eliminated the others, even if there are-    -- other constructors in the datatype.  It's still ok to make a selector-    -- thunk in this case, because we *know* which constructor the scrutinee-    -- will evaluate to.-    ---    -- srt is discarded; it must be empty-    let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)-    in cgRhsStdThunk bndr lf_info [StgVarArg the_fv]------------ Note [Ap thunks] -------------------mkRhsClosure    dflags bndr _cc-                fvs-                upd_flag-                []                      -- No args; a thunk-                (StgApp fun_id args)--  -- We are looking for an "ApThunk"; see data con ApThunk in StgCmmClosure-  -- of form (x1 x2 .... xn), where all the xi are locals (not top-level)-  -- So the xi will all be free variables-  | args `lengthIs` (n_fvs-1)  -- This happens only if the fun_id and-                               -- args are all distinct local variables-                               -- The "-1" is for fun_id-    -- Missed opportunity:   (f x x) is not detected-  , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs-  , isUpdatable upd_flag-  , n_fvs <= mAX_SPEC_AP_SIZE dflags-  , not (gopt Opt_SccProfilingOn dflags)-                         -- not when profiling: we don't want to-                         -- lose information about this particular-                         -- thunk (e.g. its type) (#949)-  , idArity fun_id == unknownArity -- don't spoil a known call--          -- Ha! an Ap thunk-  = cgRhsStdThunk bndr lf_info payload--  where-    n_fvs   = length fvs-    lf_info = mkApLFInfo bndr upd_flag n_fvs-    -- the payload has to be in the correct order, hence we can't-    -- just use the fvs.-    payload = StgVarArg fun_id : args------------ Default case -------------------mkRhsClosure dflags bndr cc fvs upd_flag args body-  = do  { let lf_info = mkClosureLFInfo dflags bndr NotTopLevel fvs upd_flag args-        ; (id_info, reg) <- rhsIdInfo bndr lf_info-        ; return (id_info, gen_code lf_info reg) }- where- gen_code lf_info reg-  = do  {       -- LAY OUT THE OBJECT-        -- If the binder is itself a free variable, then don't store-        -- it in the closure.  Instead, just bind it to Node on entry.-        -- NB we can be sure that Node will point to it, because we-        -- haven't told mkClosureLFInfo about this; so if the binder-        -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*-        -- stored in the closure itself, so it will make sure that-        -- Node points to it...-        ; let   reduced_fvs = filter (NonVoid bndr /=) fvs--        -- MAKE CLOSURE INFO FOR THIS CLOSURE-        ; mod_name <- getModuleName-        ; dflags <- getDynFlags-        ; let   name  = idName bndr-                descr = closureDescription dflags mod_name name-                fv_details :: [(NonVoid Id, ByteOff)]-                header = if isLFThunk lf_info then ThunkHeader else StdHeader-                (tot_wds, ptr_wds, fv_details)-                   = mkVirtHeapOffsets dflags header (addIdReps reduced_fvs)-                closure_info = mkClosureInfo dflags False       -- Not static-                                             bndr lf_info tot_wds ptr_wds-                                             descr--        -- BUILD ITS INFO TABLE AND CODE-        ; forkClosureBody $-                -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere-                --                  (b) ignore Sequel from context; use empty Sequel-                -- And compile the body-                closureCodeBody False bndr closure_info cc (nonVoidIds args)-                                (length args) body fv_details--        -- BUILD THE OBJECT---      ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body-        ; let use_cc = cccsExpr; blame_cc = cccsExpr-        ; emit (mkComment $ mkFastString "calling allocDynClosure")-        ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)-        ; let info_tbl = mkCmmInfo closure_info bndr currentCCS-        ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc-                                         (map toVarArg fv_details)--        -- RETURN-        ; return (mkRhsInit dflags reg lf_info hp_plus_n) }----------------------------cgRhsStdThunk-        :: Id-        -> LambdaFormInfo-        -> [StgArg]             -- payload-        -> FCode (CgIdInfo, FCode CmmAGraph)--cgRhsStdThunk bndr lf_info payload- = do  { (id_info, reg) <- rhsIdInfo bndr lf_info-       ; return (id_info, gen_code reg)-       }- where- gen_code reg  -- AHA!  A STANDARD-FORM THUNK-  = withNewTickyCounterStdThunk (lfUpdatable lf_info) (idName bndr) $-    do-  {     -- LAY OUT THE OBJECT-    mod_name <- getModuleName-  ; dflags <- getDynFlags-  ; let header = if isLFThunk lf_info then ThunkHeader else StdHeader-        (tot_wds, ptr_wds, payload_w_offsets)-            = mkVirtHeapOffsets dflags header-                (addArgReps (nonVoidStgArgs payload))--        descr = closureDescription dflags mod_name (idName bndr)-        closure_info = mkClosureInfo dflags False       -- Not static-                                     bndr lf_info tot_wds ptr_wds-                                     descr----  ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body-  ; let use_cc = cccsExpr; blame_cc = cccsExpr---        -- BUILD THE OBJECT-  ; let info_tbl = mkCmmInfo closure_info bndr currentCCS-  ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info-                                   use_cc blame_cc payload_w_offsets--        -- RETURN-  ; return (mkRhsInit dflags reg lf_info hp_plus_n) }---mkClosureLFInfo :: DynFlags-                -> Id           -- The binder-                -> TopLevelFlag -- True of top level-                -> [NonVoid Id] -- Free vars-                -> UpdateFlag   -- Update flag-                -> [Id]         -- Args-                -> LambdaFormInfo-mkClosureLFInfo dflags bndr top fvs upd_flag args-  | null args =-        mkLFThunk (idType bndr) top (map fromNonVoid fvs) upd_flag-  | otherwise =-        mkLFReEntrant top (map fromNonVoid fvs) args (mkArgDescr dflags args)------------------------------------------------------------------------------              The code for closures---------------------------------------------------------------------------closureCodeBody :: Bool            -- whether this is a top-level binding-                -> Id              -- the closure's name-                -> ClosureInfo     -- Lots of information about this closure-                -> CostCentreStack -- Optional cost centre attached to closure-                -> [NonVoid Id]    -- incoming args to the closure-                -> Int             -- arity, including void args-                -> CgStgExpr-                -> [(NonVoid Id, ByteOff)] -- the closure's free vars-                -> FCode ()--{- There are two main cases for the code for closures.--* If there are *no arguments*, then the closure is a thunk, and not in-  normal form. So it should set up an update frame (if it is-  shared). NB: Thunks cannot have a primitive type!--* If there is *at least one* argument, then this closure is in-  normal form, so there is no need to set up an update frame.--}--closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details-  | arity == 0 -- No args i.e. thunk-  = withNewTickyCounterThunk-        (isStaticClosure cl_info)-        (closureUpdReqd cl_info)-        (closureName cl_info) $-    emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $-      \(_, node, _) -> thunkCode cl_info fv_details cc node arity body-   where-     lf_info  = closureLFInfo cl_info-     info_tbl = mkCmmInfo cl_info bndr cc--closureCodeBody top_lvl bndr cl_info cc args arity body fv_details-  = -- Note: args may be [], if all args are Void-    withNewTickyCounterFun-        (closureSingleEntry cl_info)-        (closureName cl_info)-        args $ do {--        ; let-             lf_info  = closureLFInfo cl_info-             info_tbl = mkCmmInfo cl_info bndr cc--        -- Emit the main entry code-        ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $-            \(_offset, node, arg_regs) -> do-                -- Emit slow-entry code (for entering a closure through a PAP)-                { mkSlowEntryCode bndr cl_info arg_regs-                ; dflags <- getDynFlags-                ; let node_points = nodeMustPointToIt dflags lf_info-                      node' = if node_points then Just node else Nothing-                ; loop_header_id <- newBlockId-                -- Extend reader monad with information that-                -- self-recursive tail calls can be optimized into local-                -- jumps. See Note [Self-recursive tail calls] in StgCmmExpr.-                ; withSelfLoop (bndr, loop_header_id, arg_regs) $ do-                {-                -- Main payload-                ; entryHeapCheck cl_info node' arity arg_regs $ do-                { -- emit LDV code when profiling-                  when node_points (ldvEnterClosure cl_info (CmmLocal node))-                -- ticky after heap check to avoid double counting-                ; tickyEnterFun cl_info-                ; enterCostCentreFun cc-                    (CmmMachOp (mo_wordSub dflags)-                         [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]-                         , mkIntExpr dflags (funTag dflags cl_info) ])-                ; fv_bindings <- mapM bind_fv fv_details-                -- Load free vars out of closure *after*-                -- heap check, to reduce live vars over check-                ; when node_points $ load_fvs node lf_info fv_bindings-                ; void $ cgExpr body-                }}}--  }---- Note [NodeReg clobbered with loopification]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ Previously we used to pass nodeReg (aka R1) here. With profiling, upon--- entering a closure, enterFunCCS was called with R1 passed to it. But since R1--- may get clobbered inside the body of a closure, and since a self-recursive--- tail call does not restore R1, a subsequent call to enterFunCCS received a--- possibly bogus value from R1. The solution is to not pass nodeReg (aka R1) to--- enterFunCCS. Instead, we pass node, the callee-saved temporary that stores--- the original value of R1. This way R1 may get modified but loopification will--- not care.---- A function closure pointer may be tagged, so we--- must take it into account when accessing the free variables.-bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)-bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }--load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()-load_fvs node lf_info = mapM_ (\ (reg, off) ->-   do dflags <- getDynFlags-      let tag = lfDynTag dflags lf_info-      emit $ mkTaggedObjectLoad dflags reg node off tag)---------------------------------------------- The "slow entry" code for a function.  This entry point takes its--- arguments on the stack.  It loads the arguments into registers--- according to the calling convention, and jumps to the function's--- normal entry point.  The function's closure is assumed to be in--- R1/node.------ The slow entry point is used for unknown calls: eg. stg_PAP_entry--mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode ()--- If this function doesn't have a specialised ArgDescr, we need--- to generate the function's arg bitmap and slow-entry code.--- Here, we emit the slow-entry code.-mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'-  | Just (_, ArgGen _) <- closureFunInfo cl_info-  = do dflags <- getDynFlags-       let node = idToReg dflags (NonVoid bndr)-           slow_lbl = closureSlowEntryLabel  cl_info-           fast_lbl = closureLocalEntryLabel dflags cl_info-           -- mkDirectJump does not clobber `Node' containing function closure-           jump = mkJump dflags NativeNodeCall-                                (mkLblExpr fast_lbl)-                                (map (CmmReg . CmmLocal) (node : arg_regs))-                                (initUpdFrameOff dflags)-       tscope <- getTickScope-       emitProcWithConvention Slow Nothing slow_lbl-         (node : arg_regs) (jump, tscope)-  | otherwise = return ()--------------------------------------------thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack-          -> LocalReg -> Int -> CgStgExpr -> FCode ()-thunkCode cl_info fv_details _cc node arity body-  = do { dflags <- getDynFlags-       ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info)-             node'       = if node_points then Just node else Nothing-        ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling--        -- Heap overflow check-        ; entryHeapCheck cl_info node' arity [] $ do-        { -- Overwrite with black hole if necessary-          -- but *after* the heap-overflow check-        ; tickyEnterThunk cl_info-        ; when (blackHoleOnEntry cl_info && node_points)-                (blackHoleIt node)--          -- Push update frame-        ; setupUpdate cl_info node $-            -- We only enter cc after setting up update so-            -- that cc of enclosing scope will be recorded-            -- in update frame CAF/DICT functions will be-            -- subsumed by this enclosing cc-            do { enterCostCentreThunk (CmmReg nodeReg)-               ; let lf_info = closureLFInfo cl_info-               ; fv_bindings <- mapM bind_fv fv_details-               ; load_fvs node lf_info fv_bindings-               ; void $ cgExpr body }}}------------------------------------------------------------------------------              Update and black-hole wrappers---------------------------------------------------------------------------blackHoleIt :: LocalReg -> FCode ()--- Only called for closures with no args--- Node points to the closure-blackHoleIt node_reg-  = emitBlackHoleCode (CmmReg (CmmLocal node_reg))--emitBlackHoleCode :: CmmExpr -> FCode ()-emitBlackHoleCode node = do-  dflags <- getDynFlags--  -- Eager blackholing is normally disabled, but can be turned on with-  -- -feager-blackholing.  When it is on, we replace the info pointer-  -- of the thunk with stg_EAGER_BLACKHOLE_info on entry.--  -- If we wanted to do eager blackholing with slop filling, we'd need-  -- to do it at the *end* of a basic block, otherwise we overwrite-  -- the free variables in the thunk that we still need.  We have a-  -- patch for this from Andy Cheadle, but not incorporated yet. --SDM-  -- [6/2004]-  ---  -- Previously, eager blackholing was enabled when ticky-ticky was-  -- on. But it didn't work, and it wasn't strictly necessary to bring-  -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is-  -- unconditionally disabled. -- krc 1/2007--  -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,-  -- because emitBlackHoleCode is called from CmmParse.--  let  eager_blackholing =  not (gopt Opt_SccProfilingOn dflags)-                         && gopt Opt_EagerBlackHoling dflags-             -- Profiling needs slop filling (to support LDV-             -- profiling), so currently eager blackholing doesn't-             -- work with profiling.--  when eager_blackholing $ do-    emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) currentTSOExpr-    -- See Note [Heap memory barriers] in SMP.h.-    emitPrimCall [] MO_WriteBarrier []-    emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))--setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()-        -- Nota Bene: this function does not change Node (even if it's a CAF),-        -- so that the cost centre in the original closure can still be-        -- extracted by a subsequent enterCostCentre-setupUpdate closure_info node body-  | not (lfUpdatable (closureLFInfo closure_info))-  = body--  | not (isStaticClosure closure_info)-  = if not (closureUpdReqd closure_info)-      then do tickyUpdateFrameOmitted; body-      else do-          tickyPushUpdateFrame-          dflags <- getDynFlags-          let-              bh = blackHoleOnEntry closure_info &&-                   not (gopt Opt_SccProfilingOn dflags) &&-                   gopt Opt_EagerBlackHoling dflags--              lbl | bh        = mkBHUpdInfoLabel-                  | otherwise = mkUpdInfoLabel--          pushUpdateFrame lbl (CmmReg (CmmLocal node)) body--  | otherwise   -- A static closure-  = do  { tickyUpdateBhCaf closure_info--        ; if closureUpdReqd closure_info-          then do       -- Blackhole the (updatable) CAF:-                { upd_closure <- link_caf node True-                ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body }-          else do {tickyUpdateFrameOmitted; body}-    }---------------------------------------------------------------------------------- Setting up update frames---- Push the update frame on the stack in the Entry area,--- leaving room for the return address that is already--- at the old end of the area.----pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode ()-pushUpdateFrame lbl updatee body-  = do-       updfr  <- getUpdFrameOff-       dflags <- getDynFlags-       let-           hdr         = fixedHdrSize dflags-           frame       = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags-       ---       emitUpdateFrame dflags (CmmStackSlot Old frame) lbl updatee-       withUpdFrameOff frame body--emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode ()-emitUpdateFrame dflags frame lbl updatee = do-  let-           hdr         = fixedHdrSize dflags-           off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags-  ---  emitStore frame (mkLblExpr lbl)-  emitStore (cmmOffset dflags frame off_updatee) updatee-  initUpdFrameProf frame---------------------------------------------------------------------------------- Entering a CAF------ See Note [CAF management] in rts/sm/Storage.c--link_caf :: LocalReg           -- pointer to the closure-         -> Bool               -- True <=> updatable, False <=> single-entry-         -> FCode CmmExpr      -- Returns amode for closure to be updated--- This function returns the address of the black hole, so it can be--- updated with the new value when available.-link_caf node _is_upd = do-  { dflags <- getDynFlags-        -- Call the RTS function newCAF, returning the newly-allocated-        -- blackhole indirection closure-  ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing-                                    ForeignLabelInExternalPackage IsFunction-  ; bh <- newTemp (bWord dflags)-  ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl-      [ (baseExpr,  AddrHint),-        (CmmReg (CmmLocal node), AddrHint) ]-      False--  -- see Note [atomic CAF entry] in rts/sm/Storage.c-  ; updfr  <- getUpdFrameOff-  ; let target = entryCode dflags (closureInfoPtr dflags (CmmReg (CmmLocal node)))-  ; emit =<< mkCmmIfThen-      (cmmEqWord dflags (CmmReg (CmmLocal bh)) (zeroExpr dflags))-        -- re-enter the CAF-       (mkJump dflags NativeNodeCall target [] updfr)--  ; return (CmmReg (CmmLocal bh)) }-----------------------------------------------------------------------------              Profiling----------------------------------------------------------------------------- For "global" data constructors the description is simply occurrence--- name of the data constructor itself.  Otherwise it is determined by--- @closureDescription@ from the let binding information.--closureDescription :: DynFlags-           -> Module            -- Module-                   -> Name              -- Id of closure binding-                   -> String-        -- Not called for StgRhsCon which have global info tables built in-        -- CgConTbls.hs with a description generated from the data constructor-closureDescription dflags mod_name name-  = showSDocDump dflags (char '<' <>-                    (if isExternalName name-                      then ppr name -- ppr will include the module name prefix-                      else pprModule mod_name <> char '.' <> ppr name) <>-                    char '>')-   -- showSDocDump, because we want to see the unique on the Name.
− compiler/codeGen/StgCmmBind.hs-boot 
@@ -1,6 +0,0 @@-module StgCmmBind where--import StgCmmMonad( FCode )-import StgSyn( CgStgBinding )--cgBind :: CgStgBinding -> FCode ()
− compiler/codeGen/StgCmmClosure.hs 
@@ -1,999 +0,0 @@-{-# LANGUAGE CPP, RecordWildCards #-}------------------------------------------------------------------------------------- Stg to C-- code generation:------ The types   LambdaFormInfo---             ClosureInfo------ Nothing monadic in here!-----------------------------------------------------------------------------------module StgCmmClosure (-        DynTag,  tagForCon, isSmallFamily,--        idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps,-        argPrimRep,--        NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs,-        assertNonVoidIds, assertNonVoidStgArgs,--        -- * LambdaFormInfo-        LambdaFormInfo,         -- Abstract-        StandardFormInfo,        -- ...ditto...-        mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,-        mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,-        mkLFStringLit,-        lfDynTag,-        isLFThunk, isLFReEntrant, lfUpdatable,--        -- * Used by other modules-        CgLoc(..), SelfLoopInfo, CallMethod(..),-        nodeMustPointToIt, isKnownFun, funTag, tagForArity, getCallMethod,--        -- * ClosureInfo-        ClosureInfo,-        mkClosureInfo,-        mkCmmInfo,--        -- ** Inspection-        closureLFInfo, closureName,--        -- ** Labels-        -- These just need the info table label-        closureInfoLabel, staticClosureLabel,-        closureSlowEntryLabel, closureLocalEntryLabel,--        -- ** Predicates-        -- These are really just functions on LambdaFormInfo-        closureUpdReqd, closureSingleEntry,-        closureReEntrant, closureFunInfo,-        isToplevClosure,--        blackHoleOnEntry,  -- Needs LambdaFormInfo and SMRep-        isStaticClosure,   -- Needs SMPre--        -- * InfoTables-        mkDataConInfoTable,-        cafBlackHoleInfoTable,-        indStaticInfoTable,-        staticClosureNeedsLink,-    ) where--#include "../includes/MachDeps.h"--#include "GhclibHsVersions.h"--import GhcPrelude--import StgSyn-import SMRep-import Cmm-import PprCmmExpr()--import CostCentre-import BlockId-import CLabel-import Id-import IdInfo-import DataCon-import Name-import Type-import TyCoRep-import TcType-import TyCon-import RepType-import BasicTypes-import Outputable-import DynFlags-import Util--import Data.Coerce (coerce)----------------------------------------------------------------------------------                Data types and synonyms---------------------------------------------------------------------------------- These data types are mostly used by other modules, especially StgCmmMonad,--- but we define them here because some functions in this module need to--- have access to them as well--data CgLoc-  = CmmLoc CmmExpr      -- A stable CmmExpr; that is, one not mentioning-                        -- Hp, so that it remains valid across calls--  | LneLoc BlockId [LocalReg]             -- A join point-        -- A join point (= let-no-escape) should only-        -- be tail-called, and in a saturated way.-        -- To tail-call it, assign to these locals,-        -- and branch to the block id--instance Outputable CgLoc where-  ppr (CmmLoc e)    = text "cmm" <+> ppr e-  ppr (LneLoc b rs) = text "lne" <+> ppr b <+> ppr rs--type SelfLoopInfo = (Id, BlockId, [LocalReg])---- used by ticky profiling-isKnownFun :: LambdaFormInfo -> Bool-isKnownFun LFReEntrant{} = True-isKnownFun LFLetNoEscape = True-isKnownFun _             = False-------------------------------------------        Non-void types----------------------------------------- We frequently need the invariant that an Id or a an argument--- is of a non-void type. This type is a witness to the invariant.--newtype NonVoid a = NonVoid a-  deriving (Eq, Show)--fromNonVoid :: NonVoid a -> a-fromNonVoid (NonVoid a) = a--instance (Outputable a) => Outputable (NonVoid a) where-  ppr (NonVoid a) = ppr a--nonVoidIds :: [Id] -> [NonVoid Id]-nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidTy (idType id))]---- | Used in places where some invariant ensures that all these Ids are--- non-void; e.g. constructor field binders in case expressions.--- See Note [Post-unarisation invariants] in UnariseStg.-assertNonVoidIds :: [Id] -> [NonVoid Id]-assertNonVoidIds ids = ASSERT(not (any (isVoidTy . idType) ids))-                       coerce ids--nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]-nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isVoidTy (stgArgType arg))]---- | Used in places where some invariant ensures that all these arguments are--- non-void; e.g. constructor arguments.--- See Note [Post-unarisation invariants] in UnariseStg.-assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]-assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args))-                            coerce args-----------------------------------------------------------------------------------                Representations---------------------------------------------------------------------------------- Why are these here?--idPrimRep :: Id -> PrimRep-idPrimRep id = typePrimRep1 (idType id)-    -- NB: typePrimRep1 fails on unboxed tuples,-    --     but by StgCmm no Ids have unboxed tuple type--addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)]-addIdReps = map (\id -> let id' = fromNonVoid id-                         in NonVoid (idPrimRep id', id'))--addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]-addArgReps = map (\arg -> let arg' = fromNonVoid arg-                           in NonVoid (argPrimRep arg', arg'))--argPrimRep :: StgArg -> PrimRep-argPrimRep arg = typePrimRep1 (stgArgType arg)-----------------------------------------------------------------------------------                LambdaFormInfo---------------------------------------------------------------------------------- Information about an identifier, from the code generator's point of--- view.  Every identifier is bound to a LambdaFormInfo in the--- environment, which gives the code generator enough info to be able to--- tail call or return that identifier.--data LambdaFormInfo-  = LFReEntrant         -- Reentrant closure (a function)-        TopLevelFlag    -- True if top level-        OneShotInfo-        !RepArity       -- Arity. Invariant: always > 0-        !Bool           -- True <=> no fvs-        ArgDescr        -- Argument descriptor (should really be in ClosureInfo)--  | LFThunk             -- Thunk (zero arity)-        TopLevelFlag-        !Bool           -- True <=> no free vars-        !Bool           -- True <=> updatable (i.e., *not* single-entry)-        StandardFormInfo-        !Bool           -- True <=> *might* be a function type--  | LFCon               -- A saturated constructor application-        DataCon         -- The constructor--  | LFUnknown           -- Used for function arguments and imported things.-                        -- We know nothing about this closure.-                        -- Treat like updatable "LFThunk"...-                        -- Imported things which we *do* know something about use-                        -- one of the other LF constructors (eg LFReEntrant for-                        -- known functions)-        !Bool           -- True <=> *might* be a function type-                        --      The False case is good when we want to enter it,-                        --        because then we know the entry code will do-                        --        For a function, the entry code is the fast entry point--  | LFUnlifted          -- A value of unboxed type;-                        -- always a value, needs evaluation--  | LFLetNoEscape       -- See LetNoEscape module for precise description------------------------------- StandardFormInfo tells whether this thunk has one of--- a small number of standard forms--data StandardFormInfo-  = NonStandardThunk-        -- The usual case: not of the standard forms--  | SelectorThunk-        -- A SelectorThunk is of form-        --      case x of-        --           con a1,..,an -> ak-        -- and the constructor is from a single-constr type.-       WordOff          -- 0-origin offset of ak within the "goods" of-                        -- constructor (Recall that the a1,...,an may be laid-                        -- out in the heap in a non-obvious order.)--  | ApThunk-        -- An ApThunk is of form-        --        x1 ... xn-        -- The code for the thunk just pushes x2..xn on the stack and enters x1.-        -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled-        -- in the RTS to save space.-        RepArity                -- Arity, n------------------------------------------------------------                Building LambdaFormInfo---------------------------------------------------------mkLFArgument :: Id -> LambdaFormInfo-mkLFArgument id-  | isUnliftedType ty      = LFUnlifted-  | might_be_a_function ty = LFUnknown True-  | otherwise              = LFUnknown False-  where-    ty = idType id----------------mkLFLetNoEscape :: LambdaFormInfo-mkLFLetNoEscape = LFLetNoEscape----------------mkLFReEntrant :: TopLevelFlag    -- True of top level-              -> [Id]            -- Free vars-              -> [Id]            -- Args-              -> ArgDescr        -- Argument descriptor-              -> LambdaFormInfo--mkLFReEntrant _ _ [] _-  = pprPanic "mkLFReEntrant" empty-mkLFReEntrant top fvs args arg_descr-  = LFReEntrant top os_info (length args) (null fvs) arg_descr-  where os_info = idOneShotInfo (head args)----------------mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo-mkLFThunk thunk_ty top fvs upd_flag-  = ASSERT( not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty) )-    LFThunk top (null fvs)-            (isUpdatable upd_flag)-            NonStandardThunk-            (might_be_a_function thunk_ty)-----------------might_be_a_function :: Type -> Bool--- Return False only if we are *sure* it's a data type--- Look through newtypes etc as much as poss-might_be_a_function ty-  | [LiftedRep] <- typePrimRep ty-  , Just tc <- tyConAppTyCon_maybe (unwrapType ty)-  , isDataTyCon tc-  = False-  | otherwise-  = True----------------mkConLFInfo :: DataCon -> LambdaFormInfo-mkConLFInfo con = LFCon con----------------mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo-mkSelectorLFInfo id offset updatable-  = LFThunk NotTopLevel False updatable (SelectorThunk offset)-        (might_be_a_function (idType id))----------------mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo-mkApLFInfo id upd_flag arity-  = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)-        (might_be_a_function (idType id))----------------mkLFImported :: Id -> LambdaFormInfo-mkLFImported id-  | Just con <- isDataConWorkId_maybe id-  , isNullaryRepDataCon con-  = LFCon con   -- An imported nullary constructor-                -- We assume that the constructor is evaluated so that-                -- the id really does point directly to the constructor--  | arity > 0-  = LFReEntrant TopLevel noOneShotInfo arity True (panic "arg_descr")--  | otherwise-  = mkLFArgument id -- Not sure of exact arity-  where-    arity = idFunRepArity id----------------mkLFStringLit :: LambdaFormInfo-mkLFStringLit = LFUnlifted----------------------------------------------------------                Dynamic pointer tagging--------------------------------------------------------type DynTag = Int       -- The tag on a *pointer*-                        -- (from the dynamic-tagging paper)---- Note [Data constructor dynamic tags]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ The family size of a data type (the number of constructors--- or the arity of a function) can be either:---    * small, if the family size < 2**tag_bits---    * big, otherwise.------ Small families can have the constructor tag in the tag bits.--- 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 = min (dataConTag con) (mAX_PTR_TAG dflags)--- NB: 1-indexed--tagForArity :: DynFlags -> RepArity -> DynTag-tagForArity dflags arity- | isSmallFamily dflags arity = arity- | otherwise                  = 0--lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag--- Return the tag in the low order bits of a variable bound--- to this LambdaForm-lfDynTag dflags (LFCon con)                 = tagForCon dflags con-lfDynTag dflags (LFReEntrant _ _ arity _ _) = tagForArity dflags arity-lfDynTag _      _other                      = 0-----------------------------------------------------------------------------------                Observing LambdaFormInfo---------------------------------------------------------------------------------------------isLFThunk :: LambdaFormInfo -> Bool-isLFThunk (LFThunk {})  = True-isLFThunk _ = False--isLFReEntrant :: LambdaFormInfo -> Bool-isLFReEntrant (LFReEntrant {}) = True-isLFReEntrant _                = False----------------------------------------------------------------------------------                Choosing SM reps--------------------------------------------------------------------------------lfClosureType :: LambdaFormInfo -> ClosureTypeInfo-lfClosureType (LFReEntrant _ _ arity _ argd) = Fun arity argd-lfClosureType (LFCon con)                    = Constr (dataConTagZ con)-                                                      (dataConIdentity con)-lfClosureType (LFThunk _ _ _ is_sel _)       = thunkClosureType is_sel-lfClosureType _                              = panic "lfClosureType"--thunkClosureType :: StandardFormInfo -> ClosureTypeInfo-thunkClosureType (SelectorThunk off) = ThunkSelector off-thunkClosureType _                   = Thunk---- We *do* get non-updatable top-level thunks sometimes.  eg. f = g--- gets compiled to a jump to g (if g has non-zero arity), instead of--- messing around with update frames and PAPs.  We set the closure type--- to FUN_STATIC in this case.----------------------------------------------------------------------------------                nodeMustPointToIt--------------------------------------------------------------------------------nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool--- If nodeMustPointToIt is true, then the entry convention for--- this closure has R1 (the "Node" register) pointing to the--- closure itself --- the "self" argument--nodeMustPointToIt _ (LFReEntrant top _ _ no_fvs _)-  =  not no_fvs          -- Certainly if it has fvs we need to point to it-  || isNotTopLevel top   -- See Note [GC recovery]-        -- For lex_profiling we also access the cost centre for a-        -- non-inherited (i.e. non-top-level) function.-        -- The isNotTopLevel test above ensures this is ok.--nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _)-  =  not no_fvs            -- Self parameter-  || isNotTopLevel top     -- Note [GC recovery]-  || updatable             -- Need to push update frame-  || gopt Opt_SccProfilingOn dflags-          -- For the non-updatable (single-entry case):-          ---          -- True if has fvs (in which case we need access to them, and we-          --                    should black-hole it)-          -- or profiling (in which case we need to recover the cost centre-          --                 from inside it)  ToDo: do we need this even for-          --                                    top-level thunks? If not,-          --                                    isNotTopLevel subsumes this--nodeMustPointToIt _ (LFThunk {})        -- Node must point to a standard-form thunk-  = True--nodeMustPointToIt _ (LFCon _) = True--        -- Strictly speaking, the above two don't need Node to point-        -- to it if the arity = 0.  But this is a *really* unlikely-        -- situation.  If we know it's nil (say) and we are entering-        -- it. Eg: let x = [] in x then we will certainly have inlined-        -- x, since nil is a simple atom.  So we gain little by not-        -- having Node point to known zero-arity things.  On the other-        -- hand, we do lose something; Patrick's code for figuring out-        -- when something has been updated but not entered relies on-        -- having Node point to the result of an update.  SLPJ-        -- 27/11/92.--nodeMustPointToIt _ (LFUnknown _)   = True-nodeMustPointToIt _ LFUnlifted      = False-nodeMustPointToIt _ LFLetNoEscape   = False--{- Note [GC recovery]-~~~~~~~~~~~~~~~~~~~~~-If we a have a local let-binding (function or thunk)-   let f = <body> in ...-AND <body> allocates, then the heap-overflow check needs to know how-to re-start the evaluation.  It uses the "self" pointer to do this.-So even if there are no free variables in <body>, we still make-nodeMustPointToIt be True for non-top-level bindings.--Why do any such bindings exist?  After all, let-floating should have-floated them out.  Well, a clever optimiser might leave one there to-avoid a space leak, deliberately recomputing a thunk.  Also (and this-really does happen occasionally) let-floating may make a function f smaller-so it can be inlined, so now (f True) may generate a local no-fv closure.-This actually happened during bootstrapping GHC itself, with f=mkRdrFunBind-in TcGenDeriv.) -}----------------------------------------------------------------------------------                getCallMethod--------------------------------------------------------------------------------{- The entry conventions depend on the type of closure being entered,-whether or not it has free variables, and whether we're running-sequentially or in parallel.--Closure                           Node   Argument   Enter-Characteristics              Par   Req'd  Passing    Via-----------------------------------------------------------------------------Unknown                     & no  & yes & stack     & node-Known fun (>1 arg), no fvs  & no  & no  & registers & fast entry (enough args)-                                                    & slow entry (otherwise)-Known fun (>1 arg), fvs     & no  & yes & registers & fast entry (enough args)-0 arg, no fvs \r,\s         & no  & no  & n/a       & direct entry-0 arg, no fvs \u            & no  & yes & n/a       & node-0 arg, fvs \r,\s,selector   & no  & yes & n/a       & node-0 arg, fvs \r,\s            & no  & yes & n/a       & direct entry-0 arg, fvs \u               & no  & yes & n/a       & node-Unknown                     & yes & yes & stack     & node-Known fun (>1 arg), no fvs  & yes & no  & registers & fast entry (enough args)-                                                    & slow entry (otherwise)-Known fun (>1 arg), fvs     & yes & yes & registers & node-0 arg, fvs \r,\s,selector   & yes & yes & n/a       & node-0 arg, no fvs \r,\s         & yes & no  & n/a       & direct entry-0 arg, no fvs \u            & yes & yes & n/a       & node-0 arg, fvs \r,\s            & yes & yes & n/a       & node-0 arg, fvs \u               & yes & yes & n/a       & node--When black-holing, single-entry closures could also be entered via node-(rather than directly) to catch double-entry. -}--data CallMethod-  = EnterIt             -- No args, not a function--  | JumpToIt BlockId [LocalReg] -- A join point or a header of a local loop--  | ReturnIt            -- It's a value (function, unboxed value,-                        -- or constructor), so just return it.--  | SlowCall                -- Unknown fun, or known fun with-                        -- too few args.--  | DirectEntry         -- Jump directly, with args in regs-        CLabel          --   The code label-        RepArity        --   Its arity--getCallMethod :: DynFlags-              -> Name           -- Function being applied-              -> Id             -- Function Id used to chech if it can refer to-                                -- CAF's and whether the function is tail-calling-                                -- itself-              -> LambdaFormInfo -- Its info-              -> RepArity       -- Number of available arguments-              -> RepArity       -- Number of them being void arguments-              -> CgLoc          -- Passed in from cgIdApp so that we can-                                -- handle let-no-escape bindings and self-recursive-                                -- tail calls using the same data constructor,-                                -- JumpToIt. This saves us one case branch in-                                -- cgIdApp-              -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call?-              -> CallMethod--getCallMethod dflags _ id _ n_args v_args _cg_loc-              (Just (self_loop_id, block_id, args))-  | gopt Opt_Loopification dflags-  , id == self_loop_id-  , args `lengthIs` (n_args - v_args)-  -- If these patterns match then we know that:-  --   * loopification optimisation is turned on-  --   * function is performing a self-recursive call in a tail position-  --   * number of non-void parameters of the function matches functions arity.-  -- See Note [Self-recursive tail calls] and Note [Void arguments in-  -- self-recursive tail calls] in StgCmmExpr for more details-  = JumpToIt block_id args--getCallMethod dflags name id (LFReEntrant _ _ arity _ _) n_args _v_args _cg_loc-              _self_loop_info-  | n_args == 0 -- No args at all-  && not (gopt Opt_SccProfilingOn dflags)-     -- See Note [Evaluating functions with profiling] in rts/Apply.cmm-  = ASSERT( arity /= 0 ) ReturnIt-  | n_args < arity = SlowCall        -- Not enough args-  | otherwise      = DirectEntry (enterIdLabel dflags name (idCafInfo id)) arity--getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info-  = ASSERT( n_args == 0 ) ReturnIt--getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info-  = ASSERT( n_args == 0 ) ReturnIt-    -- n_args=0 because it'd be ill-typed to apply a saturated-    --          constructor application to anything--getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)-              n_args _v_args _cg_loc _self_loop_info-  | is_fun      -- it *might* be a function, so we must "call" it (which is always safe)-  = SlowCall    -- We cannot just enter it [in eval/apply, the entry code-                -- is the fast-entry code]--  -- Since is_fun is False, we are *definitely* looking at a data value-  | updatable || gopt Opt_Ticky dflags -- to catch double entry-      {- OLD: || opt_SMP-         I decided to remove this, because in SMP mode it doesn't matter-         if we enter the same thunk multiple times, so the optimisation-         of jumping directly to the entry code is still valid.  --SDM-        -}-  = EnterIt--  -- even a non-updatable selector thunk can be updated by the garbage-  -- collector, so we must enter it. (#8817)-  | SelectorThunk{} <- std_form_info-  = EnterIt--    -- We used to have ASSERT( n_args == 0 ), but actually it is-    -- possible for the optimiser to generate-    --   let bot :: Int = error Int "urk"-    --   in (bot `cast` unsafeCoerce Int (Int -> Int)) 3-    -- This happens as a result of the case-of-error transformation-    -- So the right thing to do is just to enter the thing--  | otherwise        -- Jump direct to code for single-entry thunks-  = ASSERT( n_args == 0 )-    DirectEntry (thunkEntryLabel dflags name (idCafInfo id) std_form_info-                updatable) 0--getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info-  = SlowCall -- might be a function--getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info-  = ASSERT2( n_args == 0, ppr name <+> ppr n_args )-    EnterIt -- Not a function--getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs)-              _self_loop_info-  = JumpToIt blk_id lne_regs--getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method"----------------------------------------------------------------------------------              Data types for closure information---------------------------------------------------------------------------------{- ClosureInfo: information about a binding--   We make a ClosureInfo for each let binding (both top level and not),-   but not bindings for data constructors: for those we build a CmmInfoTable-   directly (see mkDataConInfoTable).--   To a first approximation:-       ClosureInfo = (LambdaFormInfo, CmmInfoTable)--   A ClosureInfo has enough information-     a) to construct the info table itself, and build other things-        related to the binding (e.g. slow entry points for a function)-     b) to allocate a closure containing that info pointer (i.e.-           it knows the info table label)--}--data ClosureInfo-  = ClosureInfo {-        closureName :: !Name,           -- The thing bound to this closure-           -- we don't really need this field: it's only used in generating-           -- code for ticky and profiling, and we could pass the information-           -- around separately, but it doesn't do much harm to keep it here.--        closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon-          -- this tells us about what the closure contains: it's right-hand-side.--          -- the rest is just an unpacked CmmInfoTable.-        closureInfoLabel :: !CLabel,-        closureSMRep     :: !SMRep,          -- representation used by storage mgr-        closureProf      :: !ProfilingInfo-    }---- | Convert from 'ClosureInfo' to 'CmmInfoTable'.-mkCmmInfo :: ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable-mkCmmInfo ClosureInfo {..} id ccs-  = CmmInfoTable { cit_lbl  = closureInfoLabel-                 , cit_rep  = closureSMRep-                 , cit_prof = closureProf-                 , cit_srt  = Nothing-                 , cit_clo  = if isStaticRep closureSMRep-                                then Just (id,ccs)-                                else Nothing }-------------------------------------------        Building ClosureInfos-----------------------------------------mkClosureInfo :: DynFlags-              -> Bool                -- Is static-              -> Id-              -> LambdaFormInfo-              -> Int -> Int        -- Total and pointer words-              -> String         -- String descriptor-              -> ClosureInfo-mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr-  = ClosureInfo { closureName      = name-                , closureLFInfo    = lf_info-                , closureInfoLabel = info_lbl   -- These three fields are-                , closureSMRep     = sm_rep     -- (almost) an info table-                , closureProf      = prof }     -- (we don't have an SRT yet)-  where-    name       = idName id-    sm_rep     = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)-    prof       = mkProfilingInfo dflags id val_descr-    nonptr_wds = tot_wds - ptr_wds--    info_lbl = mkClosureInfoTableLabel id lf_info-------------------------------------------   Other functions over ClosureInfo------------------------------------------- Eager blackholing is normally disabled, but can be turned on with--- -feager-blackholing.  When it is on, we replace the info pointer of--- the thunk with stg_EAGER_BLACKHOLE_info on entry.---- If we wanted to do eager blackholing with slop filling,--- we'd need to do it at the *end* of a basic block, otherwise--- we overwrite the free variables in the thunk that we still--- need.  We have a patch for this from Andy Cheadle, but not--- incorporated yet. --SDM [6/2004]------ Previously, eager blackholing was enabled when ticky-ticky--- was on. But it didn't work, and it wasn't strictly necessary--- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING--- is unconditionally disabled. -- krc 1/2007------ Static closures are never themselves black-holed.--blackHoleOnEntry :: ClosureInfo -> Bool-blackHoleOnEntry cl_info-  | isStaticRep (closureSMRep cl_info)-  = False        -- Never black-hole a static closure--  | otherwise-  = case closureLFInfo cl_info of-      LFReEntrant {}            -> False-      LFLetNoEscape             -> False-      LFThunk _ _no_fvs upd _ _ -> upd   -- See Note [Black-holing non-updatable thunks]-      _other -> panic "blackHoleOnEntry"--{- Note [Black-holing non-updatable thunks]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must not black-hole non-updatable (single-entry) thunks otherwise-we run into issues like Trac #10414. Specifically:--  * There is no reason to black-hole a non-updatable thunk: it should-    not be competed for by multiple threads--  * It could, conceivably, cause a space leak if we don't black-hole-    it, if there was a live but never-followed pointer pointing to it.-    Let's hope that doesn't happen.--  * It is dangerous to black-hole a non-updatable thunk because-     - is not updated (of course)-     - hence, if it is black-holed and another thread tries to evaluate-       it, that thread will block forever-    This actually happened in Trac #10414.  So we do not black-hole-    non-updatable thunks.--  * How could two threads evaluate the same non-updatable (single-entry)-    thunk?  See Reid Barton's example below.--  * Only eager blackholing could possibly black-hole a non-updatable-    thunk, because lazy black-holing only affects thunks with an-    update frame on the stack.--Here is and example due to Reid Barton (Trac #10414):-    x = \u []  concat [[1], []]-with the following definitions,--    concat x = case x of-        []       -> []-        (:) x xs -> (++) x (concat xs)--    (++) xs ys = case xs of-        []         -> ys-        (:) x rest -> (:) x ((++) rest ys)--Where we use the syntax @\u []@ to denote an updatable thunk and @\s []@ to-denote a single-entry (i.e. non-updatable) thunk. After a thread evaluates @x@-to WHNF and calls @(++)@ the heap will contain the following thunks,--    x = 1 : y-    y = \u []  (++) [] z-    z = \s []  concat []--Now that the stage is set, consider the follow evaluations by two racing threads-A and B,--  1. Both threads enter @y@ before either is able to replace it with an-     indirection--  2. Thread A does the case analysis in @(++)@ and consequently enters @z@,-     replacing it with a black-hole--  3. At some later point thread B does the same case analysis and also attempts-     to enter @z@. However, it finds that it has been replaced with a black-hole-     so it blocks.--  4. Thread A eventually finishes evaluating @z@ (to @[]@) and updates @y@-     accordingly. It does *not* update @z@, however, as it is single-entry. This-     leaves Thread B blocked forever on a black-hole which will never be-     updated.--To avoid this sort of condition we never black-hole non-updatable thunks.--}--isStaticClosure :: ClosureInfo -> Bool-isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)--closureUpdReqd :: ClosureInfo -> Bool-closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info--lfUpdatable :: LambdaFormInfo -> Bool-lfUpdatable (LFThunk _ _ upd _ _)  = upd-lfUpdatable _ = False--closureSingleEntry :: ClosureInfo -> Bool-closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd-closureSingleEntry (ClosureInfo { closureLFInfo = LFReEntrant _ OneShotLam _ _ _}) = True-closureSingleEntry _ = False--closureReEntrant :: ClosureInfo -> Bool-closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant {} }) = True-closureReEntrant _ = False--closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)-closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info--lfFunInfo :: LambdaFormInfo ->  Maybe (RepArity, ArgDescr)-lfFunInfo (LFReEntrant _ _ arity _ arg_desc)  = Just (arity, arg_desc)-lfFunInfo _                                   = Nothing--funTag :: DynFlags -> ClosureInfo -> DynTag-funTag dflags (ClosureInfo { closureLFInfo = lf_info })-    = lfDynTag dflags lf_info--isToplevClosure :: ClosureInfo -> Bool-isToplevClosure (ClosureInfo { closureLFInfo = lf_info })-  = case lf_info of-      LFReEntrant TopLevel _ _ _ _ -> True-      LFThunk TopLevel _ _ _ _     -> True-      _other                       -> False-------------------------------------------   Label generation-----------------------------------------staticClosureLabel :: ClosureInfo -> CLabel-staticClosureLabel = toClosureLbl .  closureInfoLabel--closureSlowEntryLabel :: ClosureInfo -> CLabel-closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel--closureLocalEntryLabel :: DynFlags -> ClosureInfo -> CLabel-closureLocalEntryLabel dflags-  | tablesNextToCode dflags = toInfoLbl  . closureInfoLabel-  | otherwise               = toEntryLbl . closureInfoLabel--mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel-mkClosureInfoTableLabel id lf_info-  = case lf_info of-        LFThunk _ _ upd_flag (SelectorThunk offset) _-                      -> mkSelectorInfoLabel upd_flag offset--        LFThunk _ _ upd_flag (ApThunk arity) _-                      -> mkApInfoTableLabel upd_flag arity--        LFThunk{}     -> std_mk_lbl name cafs-        LFReEntrant{} -> std_mk_lbl name cafs-        _other        -> panic "closureInfoTableLabel"--  where-    name = idName id--    std_mk_lbl | is_local  = mkLocalInfoTableLabel-               | otherwise = mkInfoTableLabel--    cafs     = idCafInfo id-    is_local = isDataConWorkId id-       -- Make the _info pointer for the implicit datacon worker-       -- binding local. The reason we can do this is that importing-       -- code always either uses the _closure or _con_info. By the-       -- invariants in CorePrep anything else gets eta expanded.---thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel--- thunkEntryLabel is a local help function, not exported.  It's used from--- getCallMethod.-thunkEntryLabel dflags _thunk_id _ (ApThunk arity) upd_flag-  = enterApLabel dflags upd_flag arity-thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag-  = enterSelectorLabel dflags upd_flag offset-thunkEntryLabel dflags thunk_id c _ _-  = enterIdLabel dflags thunk_id c--enterApLabel :: DynFlags -> Bool -> Arity -> CLabel-enterApLabel dflags is_updatable arity-  | tablesNextToCode dflags = mkApInfoTableLabel is_updatable arity-  | otherwise               = mkApEntryLabel is_updatable arity--enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel-enterSelectorLabel dflags upd_flag offset-  | tablesNextToCode dflags = mkSelectorInfoLabel upd_flag offset-  | otherwise               = mkSelectorEntryLabel upd_flag offset--enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel-enterIdLabel dflags id c-  | tablesNextToCode dflags = mkInfoTableLabel id c-  | otherwise               = mkEntryLabel id c--------------------------------------------   Profiling------------------------------------------- Profiling requires two pieces of information to be determined for--- each closure's info table --- description and type.---- The description is stored directly in the @CClosureInfoTable@ when the--- info table is built.---- The type is determined from the type information stored with the @Id@--- in the closure info using @closureTypeDescr@.--mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo-mkProfilingInfo dflags id val_descr-  | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo-  | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8-  where-    ty_descr_w8  = stringToWord8s (getTyDescription (idType id))-    val_descr_w8 = stringToWord8s val_descr--getTyDescription :: Type -> String-getTyDescription ty-  = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->-    case tau_ty of-      TyVarTy _              -> "*"-      AppTy fun _            -> getTyDescription fun-      TyConApp tycon _       -> getOccString tycon-      FunTy _ res            -> '-' : '>' : fun_result res-      ForAllTy _  ty         -> getTyDescription ty-      LitTy n                -> getTyLitDescription n-      CastTy ty _            -> getTyDescription ty-      CoercionTy co          -> pprPanic "getTyDescription" (ppr co)-    }-  where-    fun_result (FunTy _ res) = '>' : fun_result res-    fun_result other         = getTyDescription other--getTyLitDescription :: TyLit -> String-getTyLitDescription l =-  case l of-    NumTyLit n -> show n-    StrTyLit n -> show n-------------------------------------------   CmmInfoTable-related things-----------------------------------------mkDataConInfoTable :: DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable-mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds- = CmmInfoTable { cit_lbl  = info_lbl-                , cit_rep  = sm_rep-                , cit_prof = prof-                , cit_srt  = Nothing-                , cit_clo  = Nothing }- where-   name = dataConName data_con-   info_lbl = mkConInfoTableLabel name NoCafRefs-   sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type-   cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con)-                  -- We keep the *zero-indexed* tag in the srt_len field-                  -- of the info table of a data constructor.--   prof | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo-        | otherwise                            = ProfilingInfo ty_descr val_descr--   ty_descr  = stringToWord8s $ occNameString $ getOccName $ dataConTyCon data_con-   val_descr = stringToWord8s $ occNameString $ getOccName data_con---- We need a black-hole closure info to pass to @allocDynClosure@ when we--- want to allocate the black hole on entry to a CAF.--cafBlackHoleInfoTable :: CmmInfoTable-cafBlackHoleInfoTable-  = CmmInfoTable { cit_lbl  = mkCAFBlackHoleInfoTableLabel-                 , cit_rep  = blackHoleRep-                 , cit_prof = NoProfilingInfo-                 , cit_srt  = Nothing-                 , cit_clo  = Nothing }--indStaticInfoTable :: CmmInfoTable-indStaticInfoTable-  = CmmInfoTable { cit_lbl  = mkIndStaticInfoLabel-                 , cit_rep  = indStaticRep-                 , cit_prof = NoProfilingInfo-                 , cit_srt  = Nothing-                 , cit_clo  = Nothing }--staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool--- A static closure needs a link field to aid the GC when traversing--- the static closure graph.  But it only needs such a field if either---        a) it has an SRT---        b) it's a constructor with one or more pointer fields--- In case (b), the constructor's fields themselves play the role--- of the SRT.-staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep }-  | isConRep smrep         = not (isStaticNoCafCon smrep)-  | otherwise              = has_srt
− compiler/codeGen/StgCmmCon.hs 
@@ -1,285 +0,0 @@-{-# LANGUAGE CPP #-}------------------------------------------------------------------------------------- Stg to C--: code generation for constructors------ This module provides the support code for StgCmm to deal with with--- constructors on the RHSs of let(rec)s.------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module StgCmmCon (-        cgTopRhsCon, buildDynCon, bindConArgs-    ) where--#include "GhclibHsVersions.h"--import GhcPrelude--import StgSyn-import CoreSyn  ( AltCon(..) )--import StgCmmMonad-import StgCmmEnv-import StgCmmHeap-import StgCmmLayout-import StgCmmUtils-import StgCmmClosure--import CmmExpr-import CmmUtils-import CLabel-import MkGraph-import SMRep-import CostCentre-import Module-import DataCon-import DynFlags-import FastString-import Id-import RepType (countConRepArgs)-import Literal-import PrelInfo-import Outputable-import Platform-import Util-import MonadUtils (mapMaybeM)--import Control.Monad-import Data.Char----------------------------------------------------------------------      Top-level constructors------------------------------------------------------------------cgTopRhsCon :: DynFlags-            -> Id               -- Name of thing bound to this RHS-            -> DataCon          -- Id-            -> [NonVoid StgArg] -- Args-            -> (CgIdInfo, FCode ())-cgTopRhsCon dflags id con args =-    let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label)-    in (id_info, gen_code)-  where-   name          = idName id-   caffy         = idCafInfo id -- any stgArgHasCafRefs args-   closure_label = mkClosureLabel name caffy--   gen_code =-     do { this_mod <- getModuleName-        ; when (platformOS (targetPlatform dflags) == OSMinGW32) $-              -- Windows DLLs have a problem with static cross-DLL refs.-              MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) )-        ; ASSERT( args `lengthIs` countConRepArgs con ) return ()--        -- LAY IT OUT-        ; let-            (tot_wds, --  #ptr_wds + #nonptr_wds-             ptr_wds, --  #ptr_wds-             nv_args_w_offsets) =-                 mkVirtHeapOffsetsWithPadding dflags StdHeader (addArgReps args)--            mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))-            mk_payload (FieldOff arg _) = do-                amode <- getArgAmode arg-                case amode of-                  CmmLit lit -> return lit-                  _          -> panic "StgCmmCon.cgTopRhsCon"--            nonptr_wds = tot_wds - ptr_wds--             -- we're not really going to emit an info table, so having-             -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields-             -- needs to poke around inside it.-            info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds---        ; payload <- mapM mk_payload nv_args_w_offsets-                -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs-                -- NB2: all the amodes should be Lits!-                --      TODO (osa): Why?--        ; let closure_rep = mkStaticClosureFields-                             dflags-                             info_tbl-                             dontCareCCS                -- Because it's static data-                             caffy                      -- Has CAF refs-                             payload--                -- BUILD THE OBJECT-        ; emitDataLits closure_label closure_rep--        ; return () }---------------------------------------------------------------------      Lay out and allocate non-top-level constructors------------------------------------------------------------------buildDynCon :: Id                 -- Name of the thing to which this constr will-                                  -- be bound-            -> Bool               -- is it genuinely bound to that name, or just-                                  -- for profiling?-            -> CostCentreStack    -- Where to grab cost centre from;-                                  -- current CCS if currentOrSubsumedCCS-            -> DataCon            -- The data constructor-            -> [NonVoid StgArg]   -- Its args-            -> FCode (CgIdInfo, FCode CmmAGraph)-               -- Return details about how to find it and initialization code-buildDynCon binder actually_bound cc con args-    = do dflags <- getDynFlags-         buildDynCon' dflags (targetPlatform dflags) binder actually_bound cc con args---buildDynCon' :: DynFlags-             -> Platform-             -> Id -> Bool-             -> CostCentreStack-             -> DataCon-             -> [NonVoid StgArg]-             -> FCode (CgIdInfo, FCode CmmAGraph)--{- We used to pass a boolean indicating whether all the-args were of size zero, so we could use a static-constructor; but I concluded that it just isn't worth it.-Now I/O uses unboxed tuples there just aren't any constructors-with all size-zero args.--The reason for having a separate argument, rather than looking at-the addr modes of the args is that we may be in a "knot", and-premature looking at the args will cause the compiler to black-hole!--}----------- buildDynCon': Nullary constructors ----------------- First we deal with the case of zero-arity constructors.  They--- will probably be unfolded, so we don't expect to see this case much,--- if at all, but it does no harm, and sets the scene for characters.------ In the case of zero-arity constructors, or, more accurately, those--- which have exclusively size-zero (VoidRep) args, we generate no code--- at all.--buildDynCon' dflags _ binder _ _cc con []-  | isNullaryRepDataCon con-  = return (litIdInfo dflags binder (mkConLFInfo con)-                (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))),-            return mkNop)---------- buildDynCon': Charlike and Intlike constructors ------------{- The following three paragraphs about @Char@-like and @Int@-like-closures are obsolete, but I don't understand the details well enough-to properly word them, sorry. I've changed the treatment of @Char@s to-be analogous to @Int@s: only a subset is preallocated, because @Char@-has now 31 bits. Only literals are handled here. -- Qrczak--Now for @Char@-like closures.  We generate an assignment of the-address of the closure to a temporary.  It would be possible simply to-generate no code, and record the addressing mode in the environment,-but we'd have to be careful if the argument wasn't a constant --- so-for simplicity we just always assign to a temporary.--Last special case: @Int@-like closures.  We only special-case the-situation in which the argument is a literal in the range-@mIN_INTLIKE@..@mAX_INTLILKE@.  NB: for @Char@-like closures we can-work with any old argument, but for @Int@-like ones the argument has-to be a literal.  Reason: @Char@ like closures have an argument type-which is guaranteed in range.--Because of this, we use can safely return an addressing mode.--We don't support this optimisation when compiling into Windows DLLs yet-because they don't support cross package data references well.--}--buildDynCon' dflags platform binder _ _cc con [arg]-  | maybeIntLikeCon con-  , platformOS platform /= OSMinGW32 || not (positionIndependent dflags)-  , NonVoid (StgLitArg (LitNumber LitNumInt val _)) <- arg-  , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer!-  , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto...-  = do  { let intlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit "stg_INTLIKE")-              val_int = fromIntegral val :: Int-              offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSizeW dflags + 1)-                -- INTLIKE closures consist of a header and one word payload-              intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW-        ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode-                 , return mkNop) }--buildDynCon' dflags platform binder _ _cc con [arg]-  | maybeCharLikeCon con-  , platformOS platform /= OSMinGW32 || not (positionIndependent dflags)-  , NonVoid (StgLitArg (LitChar val)) <- arg-  , let val_int = ord val :: Int-  , val_int <= mAX_CHARLIKE dflags-  , val_int >= mIN_CHARLIKE dflags-  = do  { let charlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit "stg_CHARLIKE")-              offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSizeW dflags + 1)-                -- CHARLIKE closures consist of a header and one word payload-              charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW-        ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode-                 , return mkNop) }---------- buildDynCon': the general case ------------buildDynCon' dflags _ binder actually_bound ccs con args-  = do  { (id_info, reg) <- rhsIdInfo binder lf_info-        ; return (id_info, gen_code reg)-        }- where-  lf_info = mkConLFInfo con--  gen_code reg-    = do  { let (tot_wds, ptr_wds, args_w_offsets)-                  = mkVirtConstrOffsets dflags (addArgReps args)-                nonptr_wds = tot_wds - ptr_wds-                info_tbl = mkDataConInfoTable dflags con False-                                ptr_wds nonptr_wds-          ; let ticky_name | actually_bound = Just binder-                           | otherwise = Nothing--          ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info-                                          use_cc blame_cc args_w_offsets-          ; return (mkRhsInit dflags reg lf_info hp_plus_n) }-    where-      use_cc      -- cost-centre to stick in the object-        | isCurrentCCS ccs = cccsExpr-        | otherwise        = panic "buildDynCon: non-current CCS not implemented"--      blame_cc = use_cc -- cost-centre on which to blame the alloc (same)---------------------------------------------------------------------      Binding constructor arguments------------------------------------------------------------------bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]--- bindConArgs is called from cgAlt of a case--- (bindConArgs con args) augments the environment with bindings for the--- binders args, assuming that we have just returned from a 'case' which--- found a con-bindConArgs (DataAlt con) base args-  = ASSERT(not (isUnboxedTupleCon con))-    do dflags <- getDynFlags-       let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args)-           tag = tagForCon dflags con--           -- The binding below forces the masking out of the tag bits-           -- when accessing the constructor field.-           bind_arg :: (NonVoid Id, ByteOff) -> FCode (Maybe LocalReg)-           bind_arg (arg@(NonVoid b), offset)-             | isDeadBinder b  -- See Note [Dead-binder optimisation] in StgCmmExpr-             = return Nothing-             | otherwise-             = do { emit $ mkTaggedObjectLoad dflags (idToReg dflags arg)-                                              base offset tag-                  ; Just <$> bindArgToReg arg }--       mapMaybeM bind_arg args_w_offsets--bindConArgs _other_con _base args-  = ASSERT( null args ) return []
− compiler/codeGen/StgCmmEnv.hs 
@@ -1,208 +0,0 @@-{-# LANGUAGE CPP #-}------------------------------------------------------------------------------------- Stg to C-- code generation: the binding environment------ (c) The University of Glasgow 2004-2006----------------------------------------------------------------------------------module StgCmmEnv (-        CgIdInfo,--        litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,-        idInfoToAmode,--        addBindC, addBindsC,--        bindArgsToRegs, bindToReg, rebindToReg,-        bindArgToReg, idToReg,-        getArgAmode, getNonVoidArgAmodes,-        getCgIdInfo,-        maybeLetNoEscape,-    ) where--#include "GhclibHsVersions.h"--import GhcPrelude--import TyCon-import StgCmmMonad-import StgCmmUtils-import StgCmmClosure--import CLabel--import BlockId-import CmmExpr-import CmmUtils-import DynFlags-import Id-import MkGraph-import Name-import Outputable-import StgSyn-import Type-import TysPrim-import UniqFM-import Util-import VarEnv------------------------------------------        Manipulating CgIdInfo----------------------------------------mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo-mkCgIdInfo id lf expr-  = CgIdInfo { cg_id = id, cg_lf = lf-             , cg_loc = CmmLoc expr }--litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo-litIdInfo dflags id lf lit-  = CgIdInfo { cg_id = id, cg_lf = lf-             , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) }-  where-    tag = lfDynTag dflags lf--lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo-lneIdInfo dflags id regs-  = CgIdInfo { cg_id = id, cg_lf = lf-             , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) }-  where-    lf     = mkLFLetNoEscape-    blk_id = mkBlockId (idUnique id)---rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)-rhsIdInfo id lf_info-  = do dflags <- getDynFlags-       reg <- newTemp (gcWord dflags)-       return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)--mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph-mkRhsInit dflags reg lf_info expr-  = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info))--idInfoToAmode :: CgIdInfo -> CmmExpr--- Returns a CmmExpr for the *tagged* pointer-idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e-idInfoToAmode cg_info-  = pprPanic "idInfoToAmode" (ppr (cg_id cg_info))        -- LneLoc--addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr--- A tag adds a byte offset to the pointer-addDynTag dflags expr tag = cmmOffsetB dflags expr tag--maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])-maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)-maybeLetNoEscape _other                                      = Nothing----------------------------------------------------------------        The binding environment------ There are three basic routines, for adding (addBindC),--- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.------------------------------------------------------------addBindC :: CgIdInfo -> FCode ()-addBindC stuff_to_bind = do-        binds <- getBinds-        setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind--addBindsC :: [CgIdInfo] -> FCode ()-addBindsC new_bindings = do-        binds <- getBinds-        let new_binds = foldl' (\ binds info -> extendVarEnv binds (cg_id info) info)-                               binds-                               new_bindings-        setBinds new_binds--getCgIdInfo :: Id -> FCode CgIdInfo-getCgIdInfo id-  = do  { dflags <- getDynFlags-        ; local_binds <- getBinds -- Try local bindings first-        ; case lookupVarEnv local_binds id of {-            Just info -> return info ;-            Nothing   -> do {--                -- Should be imported; make up a CgIdInfo for it-          let name = idName id-        ; if isExternalName name then-              let ext_lbl-                      | isUnliftedType (idType id) =-                          -- An unlifted external Id must refer to a top-level-                          -- string literal. See Note [Bytes label] in CLabel.-                          ASSERT( idType id `eqType` addrPrimTy )-                          mkBytesLabel name-                      | otherwise = mkClosureLabel name $ idCafInfo id-              in return $-                  litIdInfo dflags id (mkLFImported id) (CmmLabel ext_lbl)-          else-              cgLookupPanic id -- Bug-        }}}--cgLookupPanic :: Id -> FCode a-cgLookupPanic id-  = do  local_binds <- getBinds-        pprPanic "StgCmmEnv: variable not found"-                (vcat [ppr id,-                text "local binds for:",-                pprUFM local_binds $ \infos ->-                  vcat [ ppr (cg_id info) | info <- infos ]-              ])------------------------getArgAmode :: NonVoid StgArg -> FCode CmmExpr-getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var-getArgAmode (NonVoid (StgLitArg lit)) = CmmLit <$> cgLit lit--getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]--- NB: Filters out void args,---     so the result list may be shorter than the argument list-getNonVoidArgAmodes [] = return []-getNonVoidArgAmodes (arg:args)-  | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args-  | otherwise = do { amode  <- getArgAmode (NonVoid arg)-                   ; amodes <- getNonVoidArgAmodes args-                   ; return ( amode : amodes ) }------------------------------------------------------------------------------        Interface functions for binding and re-binding names---------------------------------------------------------------------------bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg--- Bind an Id to a fresh LocalReg-bindToReg nvid@(NonVoid id) lf_info-  = do dflags <- getDynFlags-       let reg = idToReg dflags nvid-       addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))-       return reg--rebindToReg :: NonVoid Id -> FCode LocalReg--- Like bindToReg, but the Id is already in scope, so--- get its LF info from the envt-rebindToReg nvid@(NonVoid id)-  = do  { info <- getCgIdInfo id-        ; bindToReg nvid (cg_lf info) }--bindArgToReg :: NonVoid Id -> FCode LocalReg-bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)--bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]-bindArgsToRegs args = mapM bindArgToReg args--idToReg :: DynFlags -> NonVoid Id -> LocalReg--- Make a register from an Id, typically a function argument,--- free variable, or case binder------ We re-use the Unique from the Id to make it easier to see what is going on------ By now the Ids should be uniquely named; else one would worry--- about accidental collision-idToReg dflags (NonVoid id)-             = LocalReg (idUnique id)-                        (primRepCmmType dflags (idPrimRep id))
− compiler/codeGen/StgCmmExpr.hs 
@@ -1,1171 +0,0 @@-{-# LANGUAGE CPP, BangPatterns #-}------------------------------------------------------------------------------------- Stg to C-- code generation: expressions------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module StgCmmExpr ( cgExpr ) where--#include "GhclibHsVersions.h"--import GhcPrelude hiding ((<*>))--import {-# SOURCE #-} StgCmmBind ( cgBind )--import StgCmmMonad-import StgCmmHeap-import StgCmmEnv-import StgCmmCon-import StgCmmProf (saveCurrentCostCentre, restoreCurrentCostCentre, emitSetCCC)-import StgCmmLayout-import StgCmmPrim-import StgCmmHpc-import StgCmmTicky-import StgCmmUtils-import StgCmmClosure--import StgSyn--import MkGraph-import BlockId-import Cmm hiding ( succ )-import CmmInfo-import CoreSyn-import DataCon-import ForeignCall-import Id-import PrimOp-import TyCon-import Type             ( isUnliftedType )-import RepType          ( isVoidTy, countConRepArgs, primRepSlot )-import CostCentre       ( CostCentreStack, currentCCS )-import Maybes-import Util-import FastString-import Outputable-import DynFlags--import Control.Monad ( unless, void )-import Control.Arrow ( first )-import Data.Function ( on )-import Data.List     ( partition )-----------------------------------------------------------------------------              cgExpr: the main function---------------------------------------------------------------------------cgExpr  :: CgStgExpr -> FCode ReturnKind--cgExpr (StgApp fun args)     = cgIdApp fun args---- seq# a s ==> a--- See Note [seq# magic] in PrelRules-cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =-  cgIdApp a []---- dataToTag# :: a -> Int#--- See Note [dataToTag#] in primops.txt.pp-cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do-  dflags <- getDynFlags-  emitComment (mkFastString "dataToTag#")-  tmp <- newTemp (bWord dflags)-  _ <- withSequel (AssignTo [tmp] False) (cgIdApp a [])-  -- TODO: For small types look at the tag bits instead of reading info table-  emitReturn [getConstrTag dflags (cmmUntag dflags (CmmReg (CmmLocal tmp)))]--cgExpr (StgOpApp op args ty) = cgOpApp op args ty-cgExpr (StgConApp con args _)= cgConApp con args-cgExpr (StgTick t e)         = cgTick t >> cgExpr e-cgExpr (StgLit lit)       = do cmm_lit <- cgLit lit-                               emitReturn [CmmLit cmm_lit]--cgExpr (StgLet _ binds expr) = do { cgBind binds;     cgExpr expr }-cgExpr (StgLetNoEscape _ binds expr) =-  do { u <- newUnique-     ; let join_id = mkBlockId u-     ; cgLneBinds join_id binds-     ; r <- cgExpr expr-     ; emitLabel join_id-     ; return r }--cgExpr (StgCase expr bndr alt_type alts) =-  cgCase expr bndr alt_type alts--cgExpr (StgLam {}) = panic "cgExpr: StgLam"-----------------------------------------------------------------------------              Let no escape---------------------------------------------------------------------------{- Generating code for a let-no-escape binding, aka join point is very-very similar to what we do for a case expression.  The duality is-between-        let-no-escape x = b-        in e-and-        case e of ... -> b--That is, the RHS of 'x' (ie 'b') will execute *later*, just like-the alternative of the case; it needs to be compiled in an environment-in which all volatile bindings are forgotten, and the free vars are-bound only to stable things like stack locations..  The 'e' part will-execute *next*, just like the scrutinee of a case. -}----------------------------cgLneBinds :: BlockId -> CgStgBinding -> FCode ()-cgLneBinds join_id (StgNonRec bndr rhs)-  = do  { local_cc <- saveCurrentCostCentre-                -- See Note [Saving the current cost centre]-        ; (info, fcode) <- cgLetNoEscapeRhs join_id local_cc bndr rhs-        ; fcode-        ; addBindC info }--cgLneBinds join_id (StgRec pairs)-  = do  { local_cc <- saveCurrentCostCentre-        ; r <- sequence $ unzipWith (cgLetNoEscapeRhs join_id local_cc) pairs-        ; let (infos, fcodes) = unzip r-        ; addBindsC infos-        ; sequence_ fcodes-        }----------------------------cgLetNoEscapeRhs-    :: BlockId          -- join point for successor of let-no-escape-    -> Maybe LocalReg   -- Saved cost centre-    -> Id-    -> CgStgRhs-    -> FCode (CgIdInfo, FCode ())--cgLetNoEscapeRhs join_id local_cc bndr rhs =-  do { (info, rhs_code) <- cgLetNoEscapeRhsBody local_cc bndr rhs-     ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info-     ; let code = do { (_, body) <- getCodeScoped rhs_code-                     ; emitOutOfLine bid (first (<*> mkBranch join_id) body) }-     ; return (info, code)-     }--cgLetNoEscapeRhsBody-    :: Maybe LocalReg   -- Saved cost centre-    -> Id-    -> CgStgRhs-    -> FCode (CgIdInfo, FCode ())-cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure _ cc _upd args body)-  = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body-cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)-  = cgLetNoEscapeClosure bndr local_cc cc []-      (StgConApp con args (pprPanic "cgLetNoEscapeRhsBody" $-                           text "StgRhsCon doesn't have type args"))-        -- For a constructor RHS we want to generate a single chunk of-        -- code which can be jumped to from many places, which will-        -- return the constructor. It's easy; just behave as if it-        -- was an StgRhsClosure with a ConApp inside!----------------------------cgLetNoEscapeClosure-        :: Id                   -- binder-        -> Maybe LocalReg       -- Slot for saved current cost centre-        -> CostCentreStack      -- XXX: *** NOT USED *** why not?-        -> [NonVoid Id]         -- Args (as in \ args -> body)-        -> CgStgExpr            -- Body (as in above)-        -> FCode (CgIdInfo, FCode ())--cgLetNoEscapeClosure bndr cc_slot _unused_cc args body-  = do dflags <- getDynFlags-       return ( lneIdInfo dflags bndr args-              , code )-  where-   code = forkLneBody $ do {-            ; withNewTickyCounterLNE (idName bndr) args $ do-            ; restoreCurrentCostCentre cc_slot-            ; arg_regs <- bindArgsToRegs args-            ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) }------------------------------------------------------------------------------              Case expressions---------------------------------------------------------------------------{- Note [Compiling case expressions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It is quite interesting to decide whether to put a heap-check at the-start of each alternative.  Of course we certainly have to do so if-the case forces an evaluation, or if there is a primitive op which can-trigger GC.--A more interesting situation is this (a Plan-B situation)--        !P!;-        ...P...-        case x# of-          0#      -> !Q!; ...Q...-          default -> !R!; ...R...--where !x! indicates a possible heap-check point. The heap checks-in the alternatives *can* be omitted, in which case the topmost-heapcheck will take their worst case into account.--In favour of omitting !Q!, !R!:-- - *May* save a heap overflow test,-   if ...P... allocates anything.-- - We can use relative addressing from a single Hp to-   get at all the closures so allocated.-- - No need to save volatile vars etc across heap checks-   in !Q!, !R!--Against omitting !Q!, !R!--  - May put a heap-check into the inner loop.  Suppose-        the main loop is P -> R -> P -> R...-        Q is the loop exit, and only it does allocation.-    This only hurts us if P does no allocation.  If P allocates,-    then there is a heap check in the inner loop anyway.--  - May do more allocation than reqd.  This sometimes bites us-    badly.  For example, nfib (ha!) allocates about 30\% more space if the-    worst-casing is done, because many many calls to nfib are leaf calls-    which don't need to allocate anything.--    We can un-allocate, but that costs an instruction--Neither problem hurts us if there is only one alternative.--Suppose the inner loop is P->R->P->R etc.  Then here is-how many heap checks we get in the *inner loop* under various-conditions--  Alloc   Heap check in branches (!Q!, !R!)?-  P Q R      yes     no (absorb to !P!)----------------------------------------  n n n      0          0-  n y n      0          1-  n . y      1          1-  y . y      2          1-  y . n      1          1--Best choices: absorb heap checks from Q and R into !P! iff-  a) P itself does some allocation-or-  b) P does allocation, or there is exactly one alternative--We adopt (b) because that is more likely to put the heap check at the-entry to a function, when not many things are live.  After a bunch of-single-branch cases, we may have lots of things live--Hence: two basic plans for--        case e of r { alts }-------- Plan A: the general case -----------        ...save current cost centre...--        ...code for e,-           with sequel (SetLocals r)--        ...restore current cost centre...-        ...code for alts...-        ...alts do their own heap checks-------- Plan B: special case when ----------  (i)  e does not allocate or call GC-  (ii) either upstream code performs allocation-       or there is just one alternative--  Then heap allocation in the (single) case branch-  is absorbed by the upstream check.-  Very common example: primops on unboxed values--        ...code for e,-           with sequel (SetLocals r)...--        ...code for alts...-        ...no heap check...--}------------------------------------------data GcPlan-  = GcInAlts            -- Put a GC check at the start the case alternatives,-        [LocalReg]      -- which binds these registers-  | NoGcInAlts          -- The scrutinee is a primitive value, or a call to a-                        -- primitive op which does no GC.  Absorb the allocation-                        -- of the case alternative(s) into the upstream check----------------------------------------cgCase :: CgStgExpr -> Id -> AltType -> [CgStgAlt] -> FCode ReturnKind--cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts-  | isEnumerationTyCon tycon -- Note [case on bool]-  = do { tag_expr <- do_enum_primop op args--       -- If the binder is not dead, convert the tag to a constructor-       -- and assign it. See Note [Dead-binder optimisation]-       ; unless (isDeadBinder bndr) $ do-            { dflags <- getDynFlags-            ; tmp_reg <- bindArgToReg (NonVoid bndr)-            ; emitAssign (CmmLocal tmp_reg)-                         (tagToClosure dflags tycon tag_expr) }--       ; (mb_deflt, branches) <- cgAlgAltRhss (NoGcInAlts,AssignedDirectly)-                                              (NonVoid bndr) alts-                                 -- See Note [GC for conditionals]-       ; emitSwitch tag_expr branches mb_deflt 0 (tyConFamilySize tycon - 1)-       ; return AssignedDirectly-       }-  where-    do_enum_primop :: PrimOp -> [StgArg] -> FCode CmmExpr-    do_enum_primop TagToEnumOp [arg]  -- No code!-      = getArgAmode (NonVoid arg)-    do_enum_primop primop args-      = do dflags <- getDynFlags-           tmp <- newTemp (bWord dflags)-           cgPrimOp [tmp] primop args-           return (CmmReg (CmmLocal tmp))--{--Note [case on bool]-~~~~~~~~~~~~~~~~~~~-This special case handles code like--  case a <# b of-    True ->-    False ->---->  case tagToEnum# (a <$# b) of-        True -> .. ; False -> ...----> case (a <$# b) of r ->-    case tagToEnum# r of-        True -> .. ; False -> ...--If we let the ordinary case code handle it, we'll get something like-- tmp1 = a < b- tmp2 = Bool_closure_tbl[tmp1]- if (tmp2 & 7 != 0) then ... // normal tagged case--but this junk won't optimise away.  What we really want is just an-inline comparison:-- if (a < b) then ...--So we add a special case to generate-- tmp1 = a < b- if (tmp1 == 0) then ...--and later optimisations will further improve this.--Now that #6135 has been resolved it should be possible to remove that-special case. The idea behind this special case and pre-6135 implementation-of Bool-returning primops was that tagToEnum# was added implicitly in the-codegen and then optimized away. Now the call to tagToEnum# is explicit-in the source code, which allows to optimize it away at the earlier stages-of compilation (i.e. at the Core level).--Note [Scrutinising VoidRep]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have this STG code:-   f = \[s : State# RealWorld] ->-       case s of _ -> blah-This is very odd.  Why are we scrutinising a state token?  But it-can arise with bizarre NOINLINE pragmas (Trac #9964)-    crash :: IO ()-    crash = IO (\s -> let {-# NOINLINE s' #-}-                          s' = s-                      in (# s', () #))--Now the trouble is that 's' has VoidRep, and we do not bind void-arguments in the environment; they don't live anywhere.  See the-calls to nonVoidIds in various places.  So we must not look up-'s' in the environment.  Instead, just evaluate the RHS!  Simple.--Note [Dead-binder optimisation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A case-binder, or data-constructor argument, may be marked as dead,-because we preserve occurrence-info on binders in CoreTidy (see-CoreTidy.tidyIdBndr).--If the binder is dead, we can sometimes eliminate a load.  While-CmmSink will eliminate that load, it's very easy to kill it at source-(giving CmmSink less work to do), and in any case CmmSink only runs-with -O. Since the majority of case binders are dead, this-optimisation probably still has a great benefit-cost ratio and we want-to keep it for -O0. See also Phab:D5358.--This probably also was the reason for occurrence hack in Phab:D5339 to-exist, perhaps because the occurrence information preserved by-'CoreTidy.tidyIdBndr' was insufficient.  But now that CmmSink does the-job we deleted the hacks.--}--cgCase (StgApp v []) _ (PrimAlt _) alts-  | isVoidRep (idPrimRep v)  -- See Note [Scrutinising VoidRep]-  , [(DEFAULT, _, rhs)] <- alts-  = cgExpr rhs--{- Note [Dodgy unsafeCoerce 1]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-    case (x :: HValue) |> co of (y :: MutVar# Int)-        DEFAULT -> ...-We want to gnerate an assignment-     y := x-We want to allow this assignment to be generated in the case when the-types are compatible, because this allows some slightly-dodgy but-occasionally-useful casts to be used, such as in RtClosureInspect-where we cast an HValue to a MutVar# so we can print out the contents-of the MutVar#.  If instead we generate code that enters the HValue,-then we'll get a runtime panic, because the HValue really is a-MutVar#.  The types are compatible though, so we can just generate an-assignment.--}-cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts-  | isUnliftedType (idType v)  -- Note [Dodgy unsafeCoerce 1]-  || reps_compatible-  = -- assignment suffices for unlifted types-    do { dflags <- getDynFlags-       ; unless reps_compatible $-           pprPanic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"-                    (pp_bndr v $$ pp_bndr bndr)-       ; v_info <- getCgIdInfo v-       ; emitAssign (CmmLocal (idToReg dflags (NonVoid bndr)))-                    (idInfoToAmode v_info)-       -- Add bndr to the environment-       ; _ <- bindArgToReg (NonVoid bndr)-       ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts }-  where-    reps_compatible = ((==) `on` (primRepSlot . idPrimRep)) v bndr-      -- Must compare SlotTys, not proper PrimReps, because with unboxed sums,-      -- the types of the binders are generated from slotPrimRep and might not-      -- match. Test case:-      --   swap :: (# Int | Int #) -> (# Int | Int #)-      --   swap (# x | #) = (# | x #)-      --   swap (# | y #) = (# y | #)--    pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id))--{- Note [Dodgy unsafeCoerce 2, #3132]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In all other cases of a lifted Id being cast to an unlifted type, the-Id should be bound to bottom, otherwise this is an unsafe use of-unsafeCoerce.  We can generate code to enter the Id and assume that-it will never return.  Hence, we emit the usual enter/return code, and-because bottom must be untagged, it will be entered.  The Sequel is a-type-correct assignment, albeit bogus.  The (dead) continuation loops;-it would be better to invoke some kind of panic function here.--}-cgCase scrut@(StgApp v []) _ (PrimAlt _) _-  = do { dflags <- getDynFlags-       ; mb_cc <- maybeSaveCostCentre True-       ; _ <- withSequel-                  (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut)-       ; restoreCurrentCostCentre mb_cc-       ; emitComment $ mkFastString "should be unreachable code"-       ; l <- newBlockId-       ; emitLabel l-       ; emit (mkBranch l)  -- an infinite loop-       ; return AssignedDirectly-       }--{- Note [Handle seq#]-~~~~~~~~~~~~~~~~~~~~~-See Note [seq# magic] in PrelRules.-The special case for seq# in cgCase does this:--  case seq# a s of v-    (# s', a' #) -> e-==>-  case a of v-    (# s', a' #) -> e--(taking advantage of the fact that the return convention for (# State#, a #)-is the same as the return convention for just 'a')--}--cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts-  = -- Note [Handle seq#]-    -- And see Note [seq# magic] in PrelRules-    -- Use the same return convention as vanilla 'a'.-    cgCase (StgApp a []) bndr alt_type alts--cgCase scrut bndr alt_type alts-  = -- the general case-    do { dflags <- getDynFlags-       ; up_hp_usg <- getVirtHp        -- Upstream heap usage-       ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts-             alt_regs  = map (idToReg dflags) ret_bndrs-       ; simple_scrut <- isSimpleScrut scrut alt_type-       ; let do_gc  | is_cmp_op scrut  = False  -- See Note [GC for conditionals]-                    | not simple_scrut = True-                    | isSingleton alts = False-                    | up_hp_usg > 0    = False-                    | otherwise        = True-               -- cf Note [Compiling case expressions]-             gc_plan = if do_gc then GcInAlts alt_regs else NoGcInAlts--       ; mb_cc <- maybeSaveCostCentre simple_scrut--       ; let sequel = AssignTo alt_regs do_gc{- Note [scrut sequel] -}-       ; ret_kind <- withSequel sequel (cgExpr scrut)-       ; restoreCurrentCostCentre mb_cc-       ; _ <- bindArgsToRegs ret_bndrs-       ; cgAlts (gc_plan,ret_kind) (NonVoid bndr) alt_type alts-       }-  where-    is_cmp_op (StgOpApp (StgPrimOp op) _ _) = isComparisonPrimOp op-    is_cmp_op _                             = False--{- Note [GC for conditionals]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For boolean conditionals it seems that we have always done NoGcInAlts.-That is, we have always done the GC check before the conditional.-This is enshrined in the special case for-   case tagToEnum# (a>b) of ...-See Note [case on bool]--It's odd, and it's flagrantly inconsistent with the rules described-Note [Compiling case expressions].  However, after eliminating the-tagToEnum# (Trac #13397) we will have:-   case (a>b) of ...-Rather than make it behave quite differently, I am testing for a-comparison operator here in in the general case as well.--ToDo: figure out what the Right Rule should be.--Note [scrut sequel]-~~~~~~~~~~~~~~~~~~~-The job of the scrutinee is to assign its value(s) to alt_regs.-Additionally, if we plan to do a heap-check in the alternatives (see-Note [Compiling case expressions]), then we *must* retreat Hp to-recover any unused heap before passing control to the sequel.  If we-don't do this, then any unused heap will become slop because the heap-check will reset the heap usage. Slop in the heap breaks LDV profiling-(+RTS -hb) which needs to do a linear sweep through the nursery.---Note [Inlining out-of-line primops and heap checks]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If shouldInlinePrimOp returns True when called from StgCmmExpr for the-purpose of heap check placement, we *must* inline the primop later in-StgCmmPrim. If we don't things will go wrong.--}--------------------maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg)-maybeSaveCostCentre simple_scrut-  | simple_scrut = return Nothing-  | otherwise    = saveCurrentCostCentre---------------------isSimpleScrut :: CgStgExpr -> AltType -> FCode Bool--- Simple scrutinee, does not block or allocate; hence safe to amalgamate--- heap usage from alternatives into the stuff before the case--- NB: if you get this wrong, and claim that the expression doesn't allocate---     when it does, you'll deeply mess up allocation-isSimpleScrut (StgOpApp op args _) _       = isSimpleOp op args-isSimpleScrut (StgLit _)       _           = return True       -- case 1# of { 0# -> ..; ... }-isSimpleScrut (StgApp _ [])    (PrimAlt _) = return True       -- case x# of { 0# -> ..; ... }-isSimpleScrut _                _           = return False--isSimpleOp :: StgOp -> [StgArg] -> FCode Bool--- True iff the op cannot block or allocate-isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe)--- dataToTag# evalautes its argument, see Note [dataToTag#] in primops.txt.pp-isSimpleOp (StgPrimOp DataToTagOp) _ = return False-isSimpleOp (StgPrimOp op) stg_args                  = do-    arg_exprs <- getNonVoidArgAmodes stg_args-    dflags <- getDynFlags-    -- See Note [Inlining out-of-line primops and heap checks]-    return $! isJust $ shouldInlinePrimOp dflags op arg_exprs-isSimpleOp (StgPrimCallOp _) _                           = return False--------------------chooseReturnBndrs :: Id -> AltType -> [CgStgAlt] -> [NonVoid Id]--- These are the binders of a case that are assigned by the evaluation of the--- scrutinee.--- They're non-void, see Note [Post-unarisation invariants] in UnariseStg.-chooseReturnBndrs bndr (PrimAlt _) _alts-  = assertNonVoidIds [bndr]--chooseReturnBndrs _bndr (MultiValAlt n) [(_, ids, _)]-  = ASSERT2(ids `lengthIs` n, ppr n $$ ppr ids $$ ppr _bndr)-    assertNonVoidIds ids     -- 'bndr' is not assigned!--chooseReturnBndrs bndr (AlgAlt _) _alts-  = assertNonVoidIds [bndr]  -- Only 'bndr' is assigned--chooseReturnBndrs bndr PolyAlt _alts-  = assertNonVoidIds [bndr]  -- Only 'bndr' is assigned--chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs"-                             -- MultiValAlt has only one alternative----------------------------------------cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [CgStgAlt]-       -> FCode ReturnKind--- At this point the result of the case are in the binders-cgAlts gc_plan _bndr PolyAlt [(_, _, rhs)]-  = maybeAltHeapCheck gc_plan (cgExpr rhs)--cgAlts gc_plan _bndr (MultiValAlt _) [(_, _, rhs)]-  = maybeAltHeapCheck gc_plan (cgExpr rhs)-        -- Here bndrs are *already* in scope, so don't rebind them--cgAlts gc_plan bndr (PrimAlt _) alts-  = do  { dflags <- getDynFlags--        ; tagged_cmms <- cgAltRhss gc_plan bndr alts--        ; let bndr_reg = CmmLocal (idToReg dflags bndr)-              (DEFAULT,deflt) = head tagged_cmms-                -- PrimAlts always have a DEFAULT case-                -- and it always comes first--              tagged_cmms' = [(lit,code)-                             | (LitAlt lit, code) <- tagged_cmms]-        ; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt-        ; return AssignedDirectly }--cgAlts gc_plan bndr (AlgAlt tycon) alts-  = do  { dflags <- getDynFlags--        ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts--        ; 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?-                -- 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, 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--- code like------ L0:---   x = R1---   goto L1--- L1:---   if (x & 7 >= 2) then goto L2 else goto L3--- L2:---   Hp = Hp + 16---   if (Hp > HpLim) then goto L4---   ...--- L4:---   call gc() returns to L5--- 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]-             -> FCode ( Maybe CmmAGraphScoped-                      , [(ConTagZ, CmmAGraphScoped)] )-cgAlgAltRhss gc_plan bndr alts-  = do { tagged_cmms <- cgAltRhss gc_plan bndr alts--       ; let { mb_deflt = case tagged_cmms of-                           ((DEFAULT,rhs) : _) -> Just rhs-                           _other              -> Nothing-                            -- DEFAULT is always first, if present--              ; branches = [ (dataConTagZ con, cmm)-                           | (DataAlt con, cmm) <- tagged_cmms ]-              }--       ; return (mb_deflt, branches)-       }-----------------------cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]-          -> FCode [(AltCon, CmmAGraphScoped)]-cgAltRhss gc_plan bndr alts = do-  dflags <- getDynFlags-  let-    base_reg = idToReg dflags bndr-    cg_alt :: CgStgAlt -> FCode (AltCon, CmmAGraphScoped)-    cg_alt (con, bndrs, rhs)-      = getCodeScoped             $-        maybeAltHeapCheck gc_plan $-        do { _ <- bindConArgs con base_reg (assertNonVoidIds bndrs)-                    -- alt binders are always non-void,-                    -- see Note [Post-unarisation invariants] in UnariseStg-           ; _ <- cgExpr rhs-           ; return con }-  forkAlts (map cg_alt alts)--maybeAltHeapCheck :: (GcPlan,ReturnKind) -> FCode a -> FCode a-maybeAltHeapCheck (NoGcInAlts,_)  code = code-maybeAltHeapCheck (GcInAlts regs, AssignedDirectly) code =-  altHeapCheck regs code-maybeAltHeapCheck (GcInAlts regs, ReturnedTo lret off) code =-  altHeapCheckReturnsTo regs lret off code----------------------------------------------------------------------------------      Tail calls--------------------------------------------------------------------------------cgConApp :: DataCon -> [StgArg] -> FCode ReturnKind-cgConApp con stg_args-  | isUnboxedTupleCon con       -- Unboxed tuple: assign and return-  = do { arg_exprs <- getNonVoidArgAmodes stg_args-       ; tickyUnboxedTupleReturn (length arg_exprs)-       ; emitReturn arg_exprs }--  | otherwise   --  Boxed constructors; allocate and return-  = ASSERT2( stg_args `lengthIs` countConRepArgs con, ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args )-    do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) False-                                     currentCCS con (assertNonVoidStgArgs stg_args)-                                     -- con args are always non-void,-                                     -- see Note [Post-unarisation invariants] in UnariseStg-                -- The first "con" says that the name bound to this-                -- closure is "con", which is a bit of a fudge, but-                -- it only affects profiling (hence the False)--        ; emit =<< fcode_init-        ; tickyReturnNewCon (length stg_args)-        ; emitReturn [idInfoToAmode idinfo] }--cgIdApp :: Id -> [StgArg] -> FCode ReturnKind-cgIdApp fun_id args = do-    dflags         <- getDynFlags-    fun_info       <- getCgIdInfo fun_id-    self_loop_info <- getSelfLoop-    let cg_fun_id   = cg_id fun_info-           -- NB: use (cg_id fun_info) instead of fun_id, because-           -- the former may be externalised for -split-objs.-           -- See Note [Externalise when splitting] in StgCmmMonad--        fun_arg     = StgVarArg cg_fun_id-        fun_name    = idName    cg_fun_id-        fun         = idInfoToAmode fun_info-        lf_info     = cg_lf         fun_info-        n_args      = length args-        v_args      = length $ filter (isVoidTy . stgArgType) args-        node_points dflags = nodeMustPointToIt dflags lf_info-    case getCallMethod dflags fun_name cg_fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of-            -- A value in WHNF, so we can just return it.-        ReturnIt-          | isVoidTy (idType fun_id) -> emitReturn []-          | otherwise                -> emitReturn [fun]-          -- ToDo: does ReturnIt guarantee tagged?--        EnterIt -> ASSERT( null args )  -- Discarding arguments-                   emitEnter fun--        SlowCall -> do      -- A slow function call via the RTS apply routines-                { tickySlowCall lf_info args-                ; emitComment $ mkFastString "slowCall"-                ; slowCall fun args }--        -- A direct function call (possibly with some left-over arguments)-        DirectEntry lbl arity -> do-                { tickyDirectCall arity args-                ; if node_points dflags-                     then directCall NativeNodeCall   lbl arity (fun_arg:args)-                     else directCall NativeDirectCall lbl arity args }--        -- Let-no-escape call or self-recursive tail-call-        JumpToIt blk_id lne_regs -> do-          { adjustHpBackwards -- always do this before a tail-call-          ; cmm_args <- getNonVoidArgAmodes args-          ; emitMultiAssign lne_regs cmm_args-          ; emit (mkBranch blk_id)-          ; return AssignedDirectly }---- Note [Self-recursive tail calls]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ Self-recursive tail calls can be optimized into a local jump in the same--- way as let-no-escape bindings (see Note [What is a non-escaping let] in--- stgSyn/CoreToStg.hs). Consider this:------ foo.info:---     a = R1  // calling convention---     b = R2---     goto L1--- L1: ...---     ...--- ...--- L2: R1 = x---     R2 = y---     call foo(R1,R2)------ Instead of putting x and y into registers (or other locations required by the--- calling convention) and performing a call we can put them into local--- variables a and b and perform jump to L1:------ foo.info:---     a = R1---     b = R2---     goto L1--- L1: ...---     ...--- ...--- L2: a = x---     b = y---     goto L1------ This can be done only when function is calling itself in a tail position--- and only if the call passes number of parameters equal to function's arity.--- Note that this cannot be performed if a function calls itself with a--- continuation.------ This in fact implements optimization known as "loopification". It was--- described in "Low-level code optimizations in the Glasgow Haskell Compiler"--- by Krzysztof Woś, though we use different approach. Krzysztof performed his--- optimization at the Cmm level, whereas we perform ours during code generation--- (Stg-to-Cmm pass) essentially making sure that optimized Cmm code is--- generated in the first place.------ Implementation is spread across a couple of places in the code:------   * FCode monad stores additional information in its reader environment---     (cgd_self_loop field). This information tells us which function can---     tail call itself in an optimized way (it is the function currently---     being compiled), what is the label of a loop header (L1 in example above)---     and information about local registers in which we should arguments---     before making a call (this would be a and b in example above).------   * Whenever we are compiling a function, we set that information to reflect---     the fact that function currently being compiled can be jumped to, instead---     of called. This is done in closureCodyBody in StgCmmBind.------   * We also have to emit a label to which we will be jumping. We make sure---     that the label is placed after a stack check but before the heap---     check. The reason is that making a recursive tail-call does not increase---     the stack so we only need to check once. But it may grow the heap, so we---     have to repeat the heap check in every self-call. This is done in---     do_checks in StgCmmHeap.------   * When we begin compilation of another closure we remove the additional---     information from the environment. This is done by forkClosureBody---     in StgCmmMonad. Other functions that duplicate the environment ----     forkLneBody, forkAlts, codeOnly - duplicate that information. In other---     words, we only need to clean the environment of the self-loop information---     when compiling right hand side of a closure (binding).------   * When compiling a call (cgIdApp) we use getCallMethod to decide what kind---     of call will be generated. getCallMethod decides to generate a self---     recursive tail call when (a) environment stores information about---     possible self tail-call; (b) that tail call is to a function currently---     being compiled; (c) number of passed non-void arguments is equal to---     function's arity. (d) loopification is turned on via -floopification---     command-line option.------   * Command line option to turn loopification on and off is implemented in---     DynFlags.--------- Note [Void arguments in self-recursive tail calls]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ State# tokens can get in the way of the loopification optimization as seen in--- #11372. Consider this:------ foo :: [a]---     -> (a -> State# s -> (# State s, Bool #))---     -> State# s---     -> (# State# s, Maybe a #)--- foo [] f s = (# s, Nothing #)--- foo (x:xs) f s = case f x s of---      (# s', b #) -> case b of---          True -> (# s', Just x #)---          False -> foo xs f s'------ We would like to compile the call to foo as a local jump instead of a call--- (see Note [Self-recursive tail calls]). However, the generated function has--- an arity of 2 while we apply it to 3 arguments, one of them being of void--- type. Thus, we mustn't count arguments of void type when checking whether--- we can turn a call into a self-recursive jump.-----emitEnter :: CmmExpr -> FCode ReturnKind-emitEnter fun = do-  { dflags <- getDynFlags-  ; adjustHpBackwards-  ; sequel <- getSequel-  ; updfr_off <- getUpdFrameOff-  ; case sequel of-      -- For a return, we have the option of generating a tag-test or-      -- not.  If the value is tagged, we can return directly, which-      -- is quicker than entering the value.  This is a code-      -- size/speed trade-off: when optimising for speed rather than-      -- size we could generate the tag test.-      ---      -- Right now, we do what the old codegen did, and omit the tag-      -- test, just generating an enter.-      Return -> do-        { let entry = entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg-        ; emit $ mkJump dflags NativeNodeCall entry-                        [cmmUntag dflags fun] updfr_off-        ; return AssignedDirectly-        }--      -- The result will be scrutinised in the sequel.  This is where-      -- we generate a tag-test to avoid entering the closure if-      -- possible.-      ---      -- The generated code will be something like this:-      ---      --    R1 = fun  -- copyout-      --    if (fun & 7 != 0) goto Lret else goto Lcall-      --  Lcall:-      --    call [fun] returns to Lret-      --  Lret:-      --    fun' = R1  -- copyin-      --    ...-      ---      -- Note in particular that the label Lret is used as a-      -- destination by both the tag-test and the call.  This is-      -- because Lret will necessarily be a proc-point, and we want to-      -- ensure that we generate only one proc-point for this-      -- sequence.-      ---      -- Furthermore, we tell the caller that we generated a native-      -- return continuation by returning (ReturnedTo Lret off), so-      -- that the continuation can be reused by the heap-check failure-      -- code in the enclosing case expression.-      ---      AssignTo res_regs _ -> do-       { lret <- newBlockId-       ; let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs []-       ; lcall <- newBlockId-       ; updfr_off <- getUpdFrameOff-       ; let area = Young lret-       ; let (outArgs, regs, copyout) = copyOutOflow dflags NativeNodeCall Call area-                                          [fun] updfr_off []-         -- refer to fun via nodeReg after the copyout, to avoid having-         -- both live simultaneously; this sometimes enables fun to be-         -- inlined in the RHS of the R1 assignment.-       ; let entry = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg))-             the_call = toCall entry (Just lret) updfr_off off outArgs regs-       ; tscope <- getTickScope-       ; emit $-           copyout <*>-           mkCbranch (cmmIsTagged dflags (CmmReg nodeReg))-                     lret lcall Nothing <*>-           outOfLine lcall (the_call,tscope) <*>-           mkLabel lret tscope <*>-           copyin-       ; return (ReturnedTo lret off)-       }-  }-----------------------------------------------------------------------------              Ticks----------------------------------------------------------------------------- | Generate Cmm code for a tick. Depending on the type of Tickish,--- this will either generate actual Cmm instrumentation code, or--- simply pass on the annotation as a @CmmTickish@.-cgTick :: Tickish Id -> FCode ()-cgTick tick-  = do { dflags <- getDynFlags-       ; case tick of-           ProfNote   cc t p -> emitSetCCC cc t p-           HpcTick    m n    -> emit (mkTickBox dflags m n)-           SourceNote s n    -> emitTick $ SourceNote s n-           _other            -> return () -- ignore-       }
− compiler/codeGen/StgCmmExtCode.hs 
@@ -1,253 +0,0 @@--- | Our extended FCode monad.---- We add a mapping from names to CmmExpr, to support local variable names in--- the concrete C-- code.  The unique supply of the underlying FCode monad--- is used to grab a new unique for each local variable.---- In C--, a local variable can be declared anywhere within a proc,--- and it scopes from the beginning of the proc to the end.  Hence, we have--- to collect declarations as we parse the proc, and feed the environment--- back in circularly (to avoid a two-pass algorithm).--module StgCmmExtCode (-        CmmParse, unEC,-        Named(..), Env,--        loopDecls,-        getEnv,--        withName,-        getName,--        newLocal,-        newLabel,-        newBlockId,-        newFunctionName,-        newImport,-        lookupLabel,-        lookupName,--        code,-        emit, emitLabel, emitAssign, emitStore,-        getCode, getCodeR, getCodeScoped,-        emitOutOfLine,-        withUpdFrameOff, getUpdFrameOff-)--where--import GhcPrelude--import qualified StgCmmMonad as F-import StgCmmMonad (FCode, newUnique)--import Cmm-import CLabel-import MkGraph--import BlockId-import DynFlags-import FastString-import Module-import UniqFM-import Unique-import UniqSupply--import Control.Monad (liftM, ap)---- | The environment contains variable definitions or blockids.-data Named-        = VarN CmmExpr          -- ^ Holds CmmLit(CmmLabel ..) which gives the label type,-                                --      eg, RtsLabel, ForeignLabel, CmmLabel etc.--        | FunN   UnitId      -- ^ A function name from this package-        | LabelN BlockId                -- ^ A blockid of some code or data.---- | An environment of named things.-type Env        = UniqFM Named---- | Local declarations that are in scope during code generation.-type Decls      = [(FastString,Named)]---- | Does a computation in the FCode monad, with a current environment---      and a list of local declarations. Returns the resulting list of declarations.-newtype CmmParse a-        = EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) }--type ExtCode = CmmParse ()--returnExtFC :: a -> CmmParse a-returnExtFC a   = EC $ \_ _ s -> return (s, a)--thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b-thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s'--instance Functor CmmParse where-      fmap = liftM--instance Applicative CmmParse where-      pure = returnExtFC-      (<*>) = ap--instance Monad CmmParse where-  (>>=) = thenExtFC--instance MonadUnique CmmParse where-  getUniqueSupplyM = code getUniqueSupplyM-  getUniqueM = EC $ \_ _ decls -> do-    u <- getUniqueM-    return (decls, u)--instance HasDynFlags CmmParse where-    getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags-                                   return (d, dflags))----- | Takes the variable decarations and imports from the monad---      and makes an environment, which is looped back into the computation.---      In this way, we can have embedded declarations that scope over the whole---      procedure, and imports that scope over the entire module.---      Discards the local declaration contained within decl'----loopDecls :: CmmParse a -> CmmParse a-loopDecls (EC fcode) =-      EC $ \c e globalDecls -> do-        (_, a) <- F.fixC $ \ ~(decls, _) ->-          fcode c (addListToUFM e decls) globalDecls-        return (globalDecls, a)----- | Get the current environment from the monad.-getEnv :: CmmParse Env-getEnv  = EC $ \_ e s -> return (s, e)---- | Get the current context name from the monad-getName :: CmmParse String-getName  = EC $ \c _ s -> return (s, c)---- | Set context name for a sub-parse-withName :: String -> CmmParse a -> CmmParse a-withName c' (EC fcode) = EC $ \_ e s -> fcode c' e s--addDecl :: FastString -> Named -> ExtCode-addDecl name named = EC $ \_ _ s -> return ((name, named) : s, ())----- | Add a new variable to the list of local declarations.---      The CmmExpr says where the value is stored.-addVarDecl :: FastString -> CmmExpr -> ExtCode-addVarDecl var expr = addDecl var (VarN expr)---- | Add a new label to the list of local declarations.-addLabel :: FastString -> BlockId -> ExtCode-addLabel name block_id = addDecl name (LabelN block_id)----- | Create a fresh local variable of a given type.-newLocal-        :: CmmType              -- ^ data type-        -> FastString           -- ^ name of variable-        -> CmmParse LocalReg    -- ^ register holding the value--newLocal ty name = do-   u <- code newUnique-   let reg = LocalReg u ty-   addVarDecl name (CmmReg (CmmLocal reg))-   return reg----- | Allocate a fresh label.-newLabel :: FastString -> CmmParse BlockId-newLabel name = do-   u <- code newUnique-   addLabel name (mkBlockId u)-   return (mkBlockId u)---- | Add add a local function to the environment.-newFunctionName-        :: FastString   -- ^ name of the function-        -> UnitId    -- ^ package of the current module-        -> ExtCode--newFunctionName name pkg = addDecl name (FunN pkg)----- | Add an imported foreign label to the list of local declarations.---      If this is done at the start of the module the declaration will scope---      over the whole module.-newImport-        :: (FastString, CLabel)-        -> CmmParse ()--newImport (name, cmmLabel)-   = addVarDecl name (CmmLit (CmmLabel cmmLabel))----- | Lookup the BlockId bound to the label with this name.---      If one hasn't been bound yet, create a fresh one based on the---      Unique of the name.-lookupLabel :: FastString -> CmmParse BlockId-lookupLabel name = do-  env <- getEnv-  return $-     case lookupUFM env name of-        Just (LabelN l) -> l-        _other          -> mkBlockId (newTagUnique (getUnique name) 'L')----- | Lookup the location of a named variable.---      Unknown names are treated as if they had been 'import'ed from the runtime system.---      This saves us a lot of bother in the RTS sources, at the expense of---      deferring some errors to link time.-lookupName :: FastString -> CmmParse CmmExpr-lookupName name = do-  env    <- getEnv-  return $-     case lookupUFM env name of-        Just (VarN e)   -> e-        Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg          name))-        _other          -> CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId name))----- | Lift an FCode computation into the CmmParse monad-code :: FCode a -> CmmParse a-code fc = EC $ \_ _ s -> do-                r <- fc-                return (s, r)--emit :: CmmAGraph -> CmmParse ()-emit = code . F.emit--emitLabel :: BlockId -> CmmParse ()-emitLabel = code . F.emitLabel--emitAssign :: CmmReg  -> CmmExpr -> CmmParse ()-emitAssign l r = code (F.emitAssign l r)--emitStore :: CmmExpr  -> CmmExpr -> CmmParse ()-emitStore l r = code (F.emitStore l r)--getCode :: CmmParse a -> CmmParse CmmAGraph-getCode (EC ec) = EC $ \c e s -> do-  ((s',_), gr) <- F.getCodeR (ec c e s)-  return (s', gr)--getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)-getCodeR (EC ec) = EC $ \c e s -> do-  ((s', r), gr) <- F.getCodeR (ec c e s)-  return (s', (r,gr))--getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped)-getCodeScoped (EC ec) = EC $ \c e s -> do-  ((s', r), gr) <- F.getCodeScoped (ec c e s)-  return (s', (r,gr))--emitOutOfLine :: BlockId -> CmmAGraphScoped -> CmmParse ()-emitOutOfLine l g = code (F.emitOutOfLine l g)--withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()-withUpdFrameOff size inner-  = EC $ \c e s -> F.withUpdFrameOff size $ (unEC inner) c e s--getUpdFrameOff :: CmmParse UpdFrameOffset-getUpdFrameOff = code $ F.getUpdFrameOff
− compiler/codeGen/StgCmmForeign.hs 
@@ -1,534 +0,0 @@------------------------------------------------------------------------------------ Code generation for foreign calls.------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module StgCmmForeign (-  cgForeignCall,-  emitPrimCall, emitCCall,-  emitForeignCall,     -- For CmmParse-  emitSaveThreadState,-  saveThreadState,-  emitLoadThreadState,-  loadThreadState,-  emitOpenNursery,-  emitCloseNursery,- ) where--import GhcPrelude hiding( succ, (<*>) )--import StgSyn-import StgCmmProf (storeCurCCS, ccsType)-import StgCmmEnv-import StgCmmMonad-import StgCmmUtils-import StgCmmClosure-import StgCmmLayout--import BlockId (newBlockId)-import Cmm-import CmmUtils-import MkGraph-import Type-import RepType-import TysPrim-import CLabel-import SMRep-import ForeignCall-import DynFlags-import Maybes-import Outputable-import UniqSupply-import BasicTypes--import Control.Monad---------------------------------------------------------------------------------- Code generation for Foreign Calls---------------------------------------------------------------------------------- | emit code for a foreign call, and return the results to the sequel.----cgForeignCall :: ForeignCall            -- the op-              -> [StgArg]               -- x,y    arguments-              -> Type                   -- result type-              -> FCode ReturnKind--cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty-  = do  { dflags <- getDynFlags-        ; let -- in the stdcall calling convention, the symbol needs @size appended-              -- to it, where size is the total number of bytes of arguments.  We-              -- attach this info to the CLabel here, and the CLabel pretty printer-              -- will generate the suffix when the label is printed.-            call_size args-              | StdCallConv <- cconv = Just (sum (map arg_size args))-              | otherwise            = Nothing--              -- ToDo: this might not be correct for 64-bit API-            arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType dflags arg)-                                     (wORD_SIZE dflags)-        ; cmm_args <- getFCallArgs stg_args-        ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty-        ; let ((call_args, arg_hints), cmm_target)-                = case target of-                   StaticTarget _ _   _      False ->-                       panic "cgForeignCall: unexpected FFI value import"-                   StaticTarget _ lbl mPkgId True-                     -> let labelSource-                                = case mPkgId of-                                        Nothing         -> ForeignLabelInThisPackage-                                        Just pkgId      -> ForeignLabelInPackage pkgId-                            size = call_size cmm_args-                        in  ( unzip cmm_args-                            , CmmLit (CmmLabel-                                        (mkForeignLabel lbl size labelSource IsFunction)))--                   DynamicTarget    ->  case cmm_args of-                                           (fn,_):rest -> (unzip rest, fn)-                                           [] -> panic "cgForeignCall []"-              fc = ForeignConvention cconv arg_hints res_hints CmmMayReturn-              call_target = ForeignTarget cmm_target fc--        -- we want to emit code for the call, and then emitReturn.-        -- However, if the sequel is AssignTo, we shortcut a little-        -- and generate a foreign call that assigns the results-        -- directly.  Otherwise we end up generating a bunch of-        -- useless "r = r" assignments, which are not merely annoying:-        -- they prevent the common block elimination from working correctly-        -- in the case of a safe foreign call.-        -- See Note [safe foreign call convention]-        ---        ; sequel <- getSequel-        ; case sequel of-            AssignTo assign_to_these _ ->-                emitForeignCall safety assign_to_these call_target call_args--            _something_else ->-                do { _ <- emitForeignCall safety res_regs call_target call_args-                   ; emitReturn (map (CmmReg . CmmLocal) res_regs)-                   }-         }--{- Note [safe foreign call convention]--The simple thing to do for a safe foreign call would be the same as an-unsafe one: just--    emitForeignCall ...-    emitReturn ...--but consider what happens in this case--   case foo x y z of-     (# s, r #) -> ...--The sequel is AssignTo [r].  The call to newUnboxedTupleRegs picks [r]-as the result reg, and we generate--  r = foo(x,y,z) returns to L1  -- emitForeignCall- L1:-  r = r  -- emitReturn-  goto L2-L2:-  ...--Now L1 is a proc point (by definition, it is the continuation of the-safe foreign call).  If L2 does a heap check, then L2 will also be a-proc point.--Furthermore, the stack layout algorithm has to arrange to save r-somewhere between the call and the jump to L1, which is annoying: we-would have to treat r differently from the other live variables, which-have to be saved *before* the call.--So we adopt a special convention for safe foreign calls: the results-are copied out according to the NativeReturn convention by the call,-and the continuation of the call should copyIn the results.  (The-copyOut code is actually inserted when the safe foreign call is-lowered later).  The result regs attached to the safe foreign call are-only used temporarily to hold the results before they are copied out.--We will now generate this:--  r = foo(x,y,z) returns to L1- L1:-  r = R1  -- copyIn, inserted by mkSafeCall-  goto L2- L2:-  ... r ...--And when the safe foreign call is lowered later (see Note [lower safe-foreign calls]) we get this:--  suspendThread()-  r = foo(x,y,z)-  resumeThread()-  R1 = r  -- copyOut, inserted by lowerSafeForeignCall-  jump L1- L1:-  r = R1  -- copyIn, inserted by mkSafeCall-  goto L2- L2:-  ... r ...--Now consider what happens if L2 does a heap check: the Adams-optimisation kicks in and commons up L1 with the heap-check-continuation, resulting in just one proc point instead of two. Yay!--}---emitCCall :: [(CmmFormal,ForeignHint)]-          -> CmmExpr-          -> [(CmmActual,ForeignHint)]-          -> FCode ()-emitCCall hinted_results fn hinted_args-  = void $ emitForeignCall PlayRisky results target args-  where-    (args, arg_hints) = unzip hinted_args-    (results, result_hints) = unzip hinted_results-    target = ForeignTarget fn fc-    fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn---emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()-emitPrimCall res op args-  = void $ emitForeignCall PlayRisky res (PrimTarget op) args---- alternative entry point, used by CmmParse-emitForeignCall-        :: Safety-        -> [CmmFormal]          -- where to put the results-        -> ForeignTarget        -- the op-        -> [CmmActual]          -- arguments-        -> FCode ReturnKind-emitForeignCall safety results target args-  | not (playSafe safety) = do-    dflags <- getDynFlags-    let (caller_save, caller_load) = callerSaveVolatileRegs dflags-    emit caller_save-    target' <- load_target_into_temp target-    args' <- mapM maybe_assign_temp args-    emit $ mkUnsafeCall target' results args'-    emit caller_load-    return AssignedDirectly--  | otherwise = do-    dflags <- getDynFlags-    updfr_off <- getUpdFrameOff-    target' <- load_target_into_temp target-    args' <- mapM maybe_assign_temp args-    k <- newBlockId-    let (off, _, copyout) = copyInOflow dflags NativeReturn (Young k) results []-       -- see Note [safe foreign call convention]-    tscope <- getTickScope-    emit $-           (    mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags)))-                        (CmmLit (CmmBlock k))-            <*> mkLast (CmmForeignCall { tgt  = target'-                                       , res  = results-                                       , args = args'-                                       , succ = k-                                       , ret_args = off-                                       , ret_off = updfr_off-                                       , intrbl = playInterruptible safety })-            <*> mkLabel k tscope-            <*> copyout-           )-    return (ReturnedTo k off)--load_target_into_temp :: ForeignTarget -> FCode ForeignTarget-load_target_into_temp (ForeignTarget expr conv) = do-  tmp <- maybe_assign_temp expr-  return (ForeignTarget tmp conv)-load_target_into_temp other_target@(PrimTarget _) =-  return other_target---- What we want to do here is create a new temporary for the foreign--- call argument if it is not safe to use the expression directly,--- because the expression mentions caller-saves GlobalRegs (see--- Note [Register Parameter Passing]).------ However, we can't pattern-match on the expression here, because--- this is used in a loop by CmmParse, and testing the expression--- results in a black hole.  So we always create a temporary, and rely--- on CmmSink to clean it up later.  (Yuck, ToDo).  The generated code--- ends up being the same, at least for the RTS .cmm code.----maybe_assign_temp :: CmmExpr -> FCode CmmExpr-maybe_assign_temp e = do-  dflags <- getDynFlags-  reg <- newTemp (cmmExprType dflags e)-  emitAssign (CmmLocal reg) e-  return (CmmReg (CmmLocal reg))---- -------------------------------------------------------------------------------- Save/restore the thread state in the TSO---- This stuff can't be done in suspendThread/resumeThread, because it--- refers to global registers which aren't available in the C world.--emitSaveThreadState :: FCode ()-emitSaveThreadState = do-  dflags <- getDynFlags-  code <- saveThreadState dflags-  emit code---- | Produce code to save the current thread state to @CurrentTSO@-saveThreadState :: MonadUnique m => DynFlags -> m CmmAGraph-saveThreadState dflags = do-  tso <- newTemp (gcWord dflags)-  close_nursery <- closeNursery dflags tso-  pure $ catAGraphs [-    -- tso = CurrentTSO;-    mkAssign (CmmLocal tso) currentTSOExpr,-    -- tso->stackobj->sp = Sp;-    mkStore (cmmOffset dflags-                       (CmmLoad (cmmOffset dflags-                                           (CmmReg (CmmLocal tso))-                                           (tso_stackobj dflags))-                                (bWord dflags))-                       (stack_SP dflags))-            spExpr,-    close_nursery,-    -- and save the current cost centre stack in the TSO when profiling:-    if gopt Opt_SccProfilingOn dflags then-        mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr-      else mkNop-    ]--emitCloseNursery :: FCode ()-emitCloseNursery = do-  dflags <- getDynFlags-  tso <- newTemp (bWord dflags)-  code <- closeNursery dflags tso-  emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code--{- |-@closeNursery dflags tso@ produces code to close the nursery.-A local register holding the value of @CurrentTSO@ is expected for-efficiency.--Closing the nursery corresponds to the following code:--@-  tso = CurrentTSO;-  cn = CurrentNuresry;--  // Update the allocation limit for the current thread.  We don't-  // check to see whether it has overflowed at this point, that check is-  // made when we run out of space in the current heap block (stg_gc_noregs)-  // and in the scheduler when context switching (schedulePostRunThread).-  tso->alloc_limit -= Hp + WDS(1) - cn->start;--  // Set cn->free to the next unoccupied word in the block-  cn->free = Hp + WDS(1);-@--}-closeNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph-closeNursery df tso = do-  let tsoreg  = CmmLocal tso-  cnreg      <- CmmLocal <$> newTemp (bWord df)-  pure $ catAGraphs [-    mkAssign cnreg currentNurseryExpr,--    -- CurrentNursery->free = Hp+1;-    mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df hpExpr 1),--    let alloc =-           CmmMachOp (mo_wordSub df)-              [ cmmOffsetW df hpExpr 1-              , CmmLoad (nursery_bdescr_start df cnreg) (bWord df)-              ]--        alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)-    in--    -- tso->alloc_limit += alloc-    mkStore alloc_limit (CmmMachOp (MO_Sub W64)-                               [ CmmLoad alloc_limit b64-                               , CmmMachOp (mo_WordTo64 df) [alloc] ])-   ]--emitLoadThreadState :: FCode ()-emitLoadThreadState = do-  dflags <- getDynFlags-  code <- loadThreadState dflags-  emit code---- | Produce code to load the current thread state from @CurrentTSO@-loadThreadState :: MonadUnique m => DynFlags -> m CmmAGraph-loadThreadState dflags = do-  tso <- newTemp (gcWord dflags)-  stack <- newTemp (gcWord dflags)-  open_nursery <- openNursery dflags tso-  pure $ catAGraphs [-    -- tso = CurrentTSO;-    mkAssign (CmmLocal tso) currentTSOExpr,-    -- stack = tso->stackobj;-    mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)),-    -- Sp = stack->sp;-    mkAssign spReg (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)),-    -- SpLim = stack->stack + RESERVED_STACK_WORDS;-    mkAssign spLimReg (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))-                                (rESERVED_STACK_WORDS dflags)),-    -- HpAlloc = 0;-    --   HpAlloc is assumed to be set to non-zero only by a failed-    --   a heap check, see HeapStackCheck.cmm:GC_GENERIC-    mkAssign hpAllocReg (zeroExpr dflags),-    open_nursery,-    -- and load the current cost centre stack from the TSO when profiling:-    if gopt Opt_SccProfilingOn dflags-       then storeCurCCS-              (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso))-                 (tso_CCCS dflags)) (ccsType dflags))-       else mkNop-   ]---emitOpenNursery :: FCode ()-emitOpenNursery = do-  dflags <- getDynFlags-  tso <- newTemp (bWord dflags)-  code <- openNursery dflags tso-  emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code--{- |-@openNursery dflags tso@ produces code to open the nursery. A local register-holding the value of @CurrentTSO@ is expected for efficiency.--Opening the nursery corresponds to the following code:--@-   tso = CurrentTSO;-   cn = CurrentNursery;-   bdfree = CurrentNursery->free;-   bdstart = CurrentNursery->start;--   // We *add* the currently occupied portion of the nursery block to-   // the allocation limit, because we will subtract it again in-   // closeNursery.-   tso->alloc_limit += bdfree - bdstart;--   // Set Hp to the last occupied word of the heap block.  Why not the-   // next unocupied word?  Doing it this way means that we get to use-   // an offset of zero more often, which might lead to slightly smaller-   // code on some architectures.-   Hp = bdfree - WDS(1);--   // Set HpLim to the end of the current nursery block (note that this block-   // might be a block group, consisting of several adjacent blocks.-   HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1;-@--}-openNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph-openNursery df tso = do-  let tsoreg =  CmmLocal tso-  cnreg      <- CmmLocal <$> newTemp (bWord df)-  bdfreereg  <- CmmLocal <$> newTemp (bWord df)-  bdstartreg <- CmmLocal <$> newTemp (bWord df)--  -- These assignments are carefully ordered to reduce register-  -- pressure and generate not completely awful code on x86.  To see-  -- what code we generate, look at the assembly for-  -- stg_returnToStackTop in rts/StgStartup.cmm.-  pure $ catAGraphs [-     mkAssign cnreg currentNurseryExpr,-     mkAssign bdfreereg  (CmmLoad (nursery_bdescr_free df cnreg)  (bWord df)),--     -- Hp = CurrentNursery->free - 1;-     mkAssign hpReg (cmmOffsetW df (CmmReg bdfreereg) (-1)),--     mkAssign bdstartreg (CmmLoad (nursery_bdescr_start df cnreg) (bWord df)),--     -- HpLim = CurrentNursery->start +-     --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;-     mkAssign hpLimReg-         (cmmOffsetExpr df-             (CmmReg bdstartreg)-             (cmmOffset df-               (CmmMachOp (mo_wordMul df) [-                 CmmMachOp (MO_SS_Conv W32 (wordWidth df))-                   [CmmLoad (nursery_bdescr_blocks df cnreg) b32],-                 mkIntExpr df (bLOCK_SIZE df)-                ])-               (-1)-             )-         ),--     -- alloc = bd->free - bd->start-     let alloc =-           CmmMachOp (mo_wordSub df) [CmmReg bdfreereg, CmmReg bdstartreg]--         alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)-     in--     -- tso->alloc_limit += alloc-     mkStore alloc_limit (CmmMachOp (MO_Add W64)-                               [ CmmLoad alloc_limit b64-                               , CmmMachOp (mo_WordTo64 df) [alloc] ])--   ]--nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks-  :: DynFlags -> CmmReg -> CmmExpr-nursery_bdescr_free   dflags cn =-  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_free dflags)-nursery_bdescr_start  dflags cn =-  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_start dflags)-nursery_bdescr_blocks dflags cn =-  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_blocks dflags)--tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff-tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags)-tso_alloc_limit dflags = closureField dflags (oFFSET_StgTSO_alloc_limit dflags)-tso_CCCS     dflags = closureField dflags (oFFSET_StgTSO_cccs dflags)-stack_STACK  dflags = closureField dflags (oFFSET_StgStack_stack dflags)-stack_SP     dflags = closureField dflags (oFFSET_StgStack_sp dflags)---closureField :: DynFlags -> ByteOff -> ByteOff-closureField dflags off = off + fixedHdrSize dflags---- -------------------------------------------------------------------------------- For certain types passed to foreign calls, we adjust the actual--- value passed to the call.  For ByteArray#/Array# we pass the--- address of the actual array, not the address of the heap object.--getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]--- (a) Drop void args--- (b) Add foreign-call shim code--- It's (b) that makes this differ from getNonVoidArgAmodes--getFCallArgs args-  = do  { mb_cmms <- mapM get args-        ; return (catMaybes mb_cmms) }-  where-    get arg | null arg_reps-            = return Nothing-            | otherwise-            = do { cmm <- getArgAmode (NonVoid arg)-                 ; dflags <- getDynFlags-                 ; return (Just (add_shim dflags arg_ty cmm, hint)) }-            where-              arg_ty   = stgArgType arg-              arg_reps = typePrimRep arg_ty-              hint     = typeForeignHint arg_ty--add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr-add_shim dflags arg_ty expr-  | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon-  = cmmOffsetB dflags expr (arrPtrsHdrSize dflags)--  | tycon == smallArrayPrimTyCon || tycon == smallMutableArrayPrimTyCon-  = cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags)--  | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon-  = cmmOffsetB dflags expr (arrWordsHdrSize dflags)--  | otherwise = expr-  where-    tycon           = tyConAppTyCon (unwrapType arg_ty)-        -- should be a tycon app, since this is a foreign call
− compiler/codeGen/StgCmmHeap.hs 
@@ -1,680 +0,0 @@------------------------------------------------------------------------------------ Stg to C--: heap management functions------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module StgCmmHeap (-        getVirtHp, setVirtHp, setRealHp,-        getHpRelOffset,--        entryHeapCheck, altHeapCheck, noEscapeHeapCheck, altHeapCheckReturnsTo,-        heapStackCheckGen,-        entryHeapCheck',--        mkStaticClosureFields, mkStaticClosure,--        allocDynClosure, allocDynClosureCmm, allocHeapClosure,-        emitSetDynHdr-    ) where--import GhcPrelude hiding ((<*>))--import StgSyn-import CLabel-import StgCmmLayout-import StgCmmUtils-import StgCmmMonad-import StgCmmProf (profDynAlloc, dynProfHdr, staticProfHdr)-import StgCmmTicky-import StgCmmClosure-import StgCmmEnv--import MkGraph--import Hoopl.Label-import SMRep-import BlockId-import Cmm-import CmmUtils-import CostCentre-import IdInfo( CafInfo(..), mayHaveCafRefs )-import Id ( Id )-import Module-import DynFlags-import FastString( mkFastString, fsLit )-import Panic( sorry )--import Control.Monad (when)-import Data.Maybe (isJust)----------------------------------------------------------------              Initialise dynamic heap objects--------------------------------------------------------------allocDynClosure-        :: Maybe Id-        -> CmmInfoTable-        -> LambdaFormInfo-        -> CmmExpr              -- Cost Centre to stick in the object-        -> CmmExpr              -- Cost Centre to blame for this alloc-                                -- (usually the same; sometimes "OVERHEAD")--        -> [(NonVoid StgArg, VirtualHpOffset)]  -- Offsets from start of object-                                                -- ie Info ptr has offset zero.-                                                -- No void args in here-        -> FCode CmmExpr -- returns Hp+n--allocDynClosureCmm-        :: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr-        -> [(CmmExpr, ByteOff)]-        -> FCode CmmExpr -- returns Hp+n---- allocDynClosure allocates the thing in the heap,--- and modifies the virtual Hp to account for this.--- The second return value is the graph that sets the value of the--- returned LocalReg, which should point to the closure after executing--- the graph.---- allocDynClosure returns an (Hp+8) CmmExpr, and hence the result is--- only valid until Hp is changed.  The caller should assign the--- result to a LocalReg if it is required to remain live.------ The reason we don't assign it to a LocalReg here is that the caller--- is often about to call regIdInfo, which immediately assigns the--- result of allocDynClosure to a new temp in order to add the tag.--- So by not generating a LocalReg here we avoid a common source of--- new temporaries and save some compile time.  This can be quite--- significant - see test T4801.---allocDynClosure mb_id info_tbl lf_info use_cc _blame_cc args_w_offsets = do-  let (args, offsets) = unzip args_w_offsets-  cmm_args <- mapM getArgAmode args     -- No void args-  allocDynClosureCmm mb_id info_tbl lf_info-                     use_cc _blame_cc (zip cmm_args offsets)---allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc amodes_w_offsets = do-  -- SAY WHAT WE ARE ABOUT TO DO-  let rep = cit_rep info_tbl-  tickyDynAlloc mb_id rep lf_info-  let info_ptr = CmmLit (CmmLabel (cit_lbl info_tbl))-  allocHeapClosure rep info_ptr use_cc amodes_w_offsets----- | Low-level heap object allocation.-allocHeapClosure-  :: SMRep                            -- ^ representation of the object-  -> CmmExpr                          -- ^ info pointer-  -> CmmExpr                          -- ^ cost centre-  -> [(CmmExpr,ByteOff)]              -- ^ payload-  -> FCode CmmExpr                    -- ^ returns the address of the object-allocHeapClosure rep info_ptr use_cc payload = do-  profDynAlloc rep use_cc--  virt_hp <- getVirtHp--  -- Find the offset of the info-ptr word-  let info_offset = virt_hp + 1-            -- info_offset is the VirtualHpOffset of the first-            -- word of the new object-            -- Remember, virtHp points to last allocated word,-            -- ie 1 *before* the info-ptr word of new object.--  base <- getHpRelOffset info_offset-  emitComment $ mkFastString "allocHeapClosure"-  emitSetDynHdr base info_ptr use_cc--  -- Fill in the fields-  hpStore base payload--  -- Bump the virtual heap pointer-  dflags <- getDynFlags-  setVirtHp (virt_hp + heapClosureSizeW dflags rep)--  return base---emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()-emitSetDynHdr base info_ptr ccs-  = do dflags <- getDynFlags-       hpStore base (zip (header dflags) [0, wORD_SIZE dflags ..])-  where-    header :: DynFlags -> [CmmExpr]-    header dflags = [info_ptr] ++ dynProfHdr dflags ccs-        -- ToDo: Parallel stuff-        -- No ticky header---- Store the item (expr,off) in base[off]-hpStore :: CmmExpr -> [(CmmExpr, ByteOff)] -> FCode ()-hpStore base vals = do-  dflags <- getDynFlags-  sequence_ $-    [ emitStore (cmmOffsetB dflags base off) val | (val,off) <- vals ]----------------------------------------------------------------              Layout of static closures---------------------------------------------------------------- Make a static closure, adding on any extra padding needed for CAFs,--- and adding a static link field if necessary.--mkStaticClosureFields-        :: DynFlags-        -> CmmInfoTable-        -> CostCentreStack-        -> CafInfo-        -> [CmmLit]             -- Payload-        -> [CmmLit]             -- The full closure-mkStaticClosureFields dflags info_tbl ccs caf_refs payload-  = mkStaticClosure dflags info_lbl ccs payload padding-        static_link_field saved_info_field-  where-    info_lbl = cit_lbl info_tbl--    -- CAFs must have consistent layout, regardless of whether they-    -- are actually updatable or not.  The layout of a CAF is:-    ---    --        3 saved_info-    --        2 static_link-    --        1 indirectee-    --        0 info ptr-    ---    -- the static_link and saved_info fields must always be in the-    -- same place.  So we use isThunkRep rather than closureUpdReqd-    -- here:--    is_caf = isThunkRep (cit_rep info_tbl)--    padding-        | is_caf && null payload = [mkIntCLit dflags 0]-        | otherwise = []--    static_link_field-        | is_caf || staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl-        = [static_link_value]-        | otherwise-        = []--    saved_info_field-        | is_caf     = [mkIntCLit dflags 0]-        | otherwise  = []--        -- For a static constructor which has NoCafRefs, we set the-        -- static link field to a non-zero value so the garbage-        -- collector will ignore it.-    static_link_value-        | mayHaveCafRefs caf_refs  = mkIntCLit dflags 0-        | otherwise                = mkIntCLit dflags 3  -- No CAF refs-                                      -- See Note [STATIC_LINK fields]-                                      -- in rts/sm/Storage.h--mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit]-  -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]-mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field-  =  [CmmLabel info_lbl]-  ++ staticProfHdr dflags ccs-  ++ payload-  ++ padding-  ++ static_link_field-  ++ saved_info_field----------------------------------------------------------------              Heap overflow checking--------------------------------------------------------------{- Note [Heap checks]-   ~~~~~~~~~~~~~~~~~~-Heap checks come in various forms.  We provide the following entry-points to the runtime system, all of which use the native C-- entry-convention.--  * gc() performs garbage collection and returns-    nothing to its caller--  * A series of canned entry points like-        r = gc_1p( r )-    where r is a pointer.  This performs gc, and-    then returns its argument r to its caller.--  * A series of canned entry points like-        gcfun_2p( f, x, y )-    where f is a function closure of arity 2-    This performs garbage collection, keeping alive the-    three argument ptrs, and then tail-calls f(x,y)--These are used in the following circumstances--* entryHeapCheck: Function entry-    (a) With a canned GC entry sequence-        f( f_clo, x:ptr, y:ptr ) {-             Hp = Hp+8-             if Hp > HpLim goto L-             ...-          L: HpAlloc = 8-             jump gcfun_2p( f_clo, x, y ) }-     Note the tail call to the garbage collector;-     it should do no register shuffling--    (b) No canned sequence-        f( f_clo, x:ptr, y:ptr, ...etc... ) {-          T: Hp = Hp+8-             if Hp > HpLim goto L-             ...-          L: HpAlloc = 8-             call gc()  -- Needs an info table-             goto T }--* altHeapCheck: Immediately following an eval-  Started as-        case f x y of r { (p,q) -> rhs }-  (a) With a canned sequence for the results of f-       (which is the very common case since-       all boxed cases return just one pointer-           ...-           r = f( x, y )-        K:      -- K needs an info table-           Hp = Hp+8-           if Hp > HpLim goto L-           ...code for rhs...--        L: r = gc_1p( r )-           goto K }--        Here, the info table needed by the call-        to gc_1p should be the *same* as the-        one for the call to f; the C-- optimiser-        spots this sharing opportunity)--   (b) No canned sequence for results of f-       Note second info table-           ...-           (r1,r2,r3) = call f( x, y )-        K:-           Hp = Hp+8-           if Hp > HpLim goto L-           ...code for rhs...--        L: call gc()    -- Extra info table here-           goto K--* generalHeapCheck: Anywhere else-  e.g. entry to thunk-       case branch *not* following eval,-       or let-no-escape-  Exactly the same as the previous case:--        K:      -- K needs an info table-           Hp = Hp+8-           if Hp > HpLim goto L-           ...--        L: call gc()-           goto K--}------------------------------------------------------------------- A heap/stack check at a function or thunk entry point.--entryHeapCheck :: ClosureInfo-               -> Maybe LocalReg -- Function (closure environment)-               -> Int            -- Arity -- not same as len args b/c of voids-               -> [LocalReg]     -- Non-void args (empty for thunk)-               -> FCode ()-               -> FCode ()--entryHeapCheck cl_info nodeSet arity args code-  = entryHeapCheck' is_fastf node arity args code-  where-    node = case nodeSet of-              Just r  -> CmmReg (CmmLocal r)-              Nothing -> CmmLit (CmmLabel $ staticClosureLabel cl_info)--    is_fastf = case closureFunInfo cl_info of-                 Just (_, ArgGen _) -> False-                 _otherwise         -> True---- | lower-level version for CmmParse-entryHeapCheck' :: Bool           -- is a known function pattern-                -> CmmExpr        -- expression for the closure pointer-                -> Int            -- Arity -- not same as len args b/c of voids-                -> [LocalReg]     -- Non-void args (empty for thunk)-                -> FCode ()-                -> FCode ()-entryHeapCheck' is_fastf node arity args code-  = do dflags <- getDynFlags-       let is_thunk = arity == 0--           args' = map (CmmReg . CmmLocal) args-           stg_gc_fun    = CmmReg (CmmGlobal GCFun)-           stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)--           {- Thunks:          jump stg_gc_enter_1--              Function (fast): call (NativeNode) stg_gc_fun(fun, args)--              Function (slow): call (slow) stg_gc_fun(fun, args)-           -}-           gc_call upd-               | is_thunk-                 = mkJump dflags NativeNodeCall stg_gc_enter1 [node] upd--               | is_fastf-                 = mkJump dflags NativeNodeCall stg_gc_fun (node : args') upd--               | otherwise-                 = mkJump dflags Slow stg_gc_fun (node : args') upd--       updfr_sz <- getUpdFrameOff--       loop_id <- newBlockId-       emitLabel loop_id-       heapCheck True True (gc_call updfr_sz <*> mkBranch loop_id) code---- --------------------------------------------------------------- A heap/stack check in a case alternative----- If there are multiple alts and we need to GC, but don't have a--- continuation already (the scrut was simple), then we should--- pre-generate the continuation.  (if there are multiple alts it is--- always a canned GC point).---- altHeapCheck:--- If we have a return continuation,---   then if it is a canned GC pattern,---           then we do mkJumpReturnsTo---           else we do a normal call to stg_gc_noregs---   else if it is a canned GC pattern,---           then generate the continuation and do mkCallReturnsTo---           else we do a normal call to stg_gc_noregs--altHeapCheck :: [LocalReg] -> FCode a -> FCode a-altHeapCheck regs code = altOrNoEscapeHeapCheck False regs code--altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a-altOrNoEscapeHeapCheck checkYield regs code = do-    dflags <- getDynFlags-    case cannedGCEntryPoint dflags regs of-      Nothing -> genericGC checkYield code-      Just gc -> do-        lret <- newBlockId-        let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs []-        lcont <- newBlockId-        tscope <- getTickScope-        emitOutOfLine lret (copyin <*> mkBranch lcont, tscope)-        emitLabel lcont-        cannedGCReturnsTo checkYield False gc regs lret off code--altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a-altHeapCheckReturnsTo regs lret off code-  = do dflags <- getDynFlags-       case cannedGCEntryPoint dflags regs of-           Nothing -> genericGC False code-           Just gc -> cannedGCReturnsTo False True gc regs lret off code---- noEscapeHeapCheck is implemented identically to altHeapCheck (which--- is more efficient), but cannot be optimized away in the non-allocating--- case because it may occur in a loop-noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a-noEscapeHeapCheck regs code = altOrNoEscapeHeapCheck True regs code--cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff-                  -> FCode a-                  -> FCode a-cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code-  = do dflags <- getDynFlags-       updfr_sz <- getUpdFrameOff-       heapCheck False checkYield (gc_call dflags gc updfr_sz) code-  where-    reg_exprs = map (CmmReg . CmmLocal) regs-      -- Note [stg_gc arguments]--      -- NB. we use the NativeReturn convention for passing arguments-      -- to the canned heap-check routines, because we are in a case-      -- alternative and hence the [LocalReg] was passed to us in the-      -- NativeReturn convention.-    gc_call dflags label sp-      | cont_on_stack-      = mkJumpReturnsTo dflags label NativeReturn reg_exprs lret off sp-      | otherwise-      = mkCallReturnsTo dflags label NativeReturn reg_exprs lret off sp []--genericGC :: Bool -> FCode a -> FCode a-genericGC checkYield code-  = do updfr_sz <- getUpdFrameOff-       lretry <- newBlockId-       emitLabel lretry-       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []-       heapCheck False checkYield (call <*> mkBranch lretry) code--cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr-cannedGCEntryPoint dflags regs-  = case map localRegType regs of-      []  -> Just (mkGcLabel "stg_gc_noregs")-      [ty]-          | isGcPtrType ty -> Just (mkGcLabel "stg_gc_unpt_r1")-          | isFloatType ty -> case width of-                                  W32       -> Just (mkGcLabel "stg_gc_f1")-                                  W64       -> Just (mkGcLabel "stg_gc_d1")-                                  _         -> Nothing--          | width == wordWidth dflags -> Just (mkGcLabel "stg_gc_unbx_r1")-          | width == W64              -> Just (mkGcLabel "stg_gc_l1")-          | otherwise                 -> Nothing-          where-              width = typeWidth ty-      [ty1,ty2]-          |  isGcPtrType ty1-          && isGcPtrType ty2 -> Just (mkGcLabel "stg_gc_pp")-      [ty1,ty2,ty3]-          |  isGcPtrType ty1-          && isGcPtrType ty2-          && isGcPtrType ty3 -> Just (mkGcLabel "stg_gc_ppp")-      [ty1,ty2,ty3,ty4]-          |  isGcPtrType ty1-          && isGcPtrType ty2-          && isGcPtrType ty3-          && isGcPtrType ty4 -> Just (mkGcLabel "stg_gc_pppp")-      _otherwise -> Nothing---- Note [stg_gc arguments]--- It might seem that we could avoid passing the arguments to the--- stg_gc function, because they are already in the right registers.--- While this is usually the case, it isn't always.  Sometimes the--- code generator has cleverly avoided the eval in a case, e.g. in--- ffi/should_run/4221.hs we found------   case a_r1mb of z---     FunPtr x y -> ...------ where a_r1mb is bound a top-level constructor, and is known to be--- evaluated.  The codegen just assigns x, y and z, and continues;--- R1 is never assigned.------ So we'll have to rely on optimisations to eliminatethese--- assignments where possible.----- | The generic GC procedure; no params, no results-generic_gc :: CmmExpr-generic_gc = mkGcLabel "stg_gc_noregs"---- | Create a CLabel for calling a garbage collector entry point-mkGcLabel :: String -> CmmExpr-mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit s)))----------------------------------heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a-heapCheck checkStack checkYield do_gc code-  = getHeapUsage $ \ hpHw ->-    -- Emit heap checks, but be sure to do it lazily so-    -- that the conditionals on hpHw don't cause a black hole-    do  { dflags <- getDynFlags-        ; let mb_alloc_bytes-                 | hpHw > mBLOCK_SIZE = sorry $ unlines-                    [" Trying to allocate more than "++show mBLOCK_SIZE++" bytes.",-                     "",-                     "This is currently not possible due to a limitation of GHC's code generator.",-                     "See http://ghc.haskell.org/trac/ghc/ticket/4505 for details.",-                     "Suggestion: read data from a file instead of having large static data",-                     "structures in code."]-                 | hpHw > 0  = Just (mkIntExpr dflags (hpHw * (wORD_SIZE dflags)))-                 | otherwise = Nothing-                 where mBLOCK_SIZE = bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE_W dflags-              stk_hwm | checkStack = Just (CmmLit CmmHighStackMark)-                      | otherwise  = Nothing-        ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc-        ; tickyAllocHeap True hpHw-        ; setRealHp hpHw-        ; code }--heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode ()-heapStackCheckGen stk_hwm mb_bytes-  = do updfr_sz <- getUpdFrameOff-       lretry <- newBlockId-       emitLabel lretry-       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []-       do_checks stk_hwm False mb_bytes (call <*> mkBranch lretry)---- Note [Single stack check]--- ~~~~~~~~~~~~~~~~~~~~~~~~~--- When compiling a function we can determine how much stack space it--- will use. We therefore need to perform only a single stack check at--- the beginning of a function to see if we have enough stack space.------ The check boils down to comparing Sp-N with SpLim, where N is the--- amount of stack space needed (see Note [Stack usage] below).  *BUT*--- at this stage of the pipeline we are not supposed to refer to Sp--- itself, because the stack is not yet manifest, so we don't quite--- know where Sp pointing.---- So instead of referring directly to Sp - as we used to do in the--- past - the code generator uses (old + 0) in the stack check. That--- is the address of the first word of the old area, so if we add N--- we'll get the address of highest used word.------ This makes the check robust.  For example, while we need to perform--- only one stack check for each function, we could in theory place--- more stack checks later in the function. They would be redundant,--- but not incorrect (in a sense that they should not change program--- behaviour). We need to make sure however that a stack check--- inserted after incrementing the stack pointer checks for a--- respectively smaller stack space. This would not be the case if the--- code generator produced direct references to Sp. By referencing--- (old + 0) we make sure that we always check for a correct amount of--- stack: when converting (old + 0) to Sp the stack layout phase takes--- into account changes already made to stack pointer. The idea for--- this change came from observations made while debugging #8275.---- Note [Stack usage]--- ~~~~~~~~~~~~~~~~~~--- At the moment we convert from STG to Cmm we don't know N, the--- number of bytes of stack that the function will use, so we use a--- special late-bound CmmLit, namely---       CmmHighStackMark--- to stand for the number of bytes needed. When the stack is made--- manifest, the number of bytes needed is calculated, and used to--- replace occurrences of CmmHighStackMark------ The (Maybe CmmExpr) passed to do_checks is usually---     Just (CmmLit CmmHighStackMark)--- but can also (in certain hand-written RTS functions)---     Just (CmmLit 8)  or some other fixed valuet--- If it is Nothing, we don't generate a stack check at all.--do_checks :: Maybe CmmExpr    -- Should we check the stack?-                              -- See Note [Stack usage]-          -> Bool             -- Should we check for preemption?-          -> Maybe CmmExpr    -- Heap headroom (bytes)-          -> CmmAGraph        -- What to do on failure-          -> FCode ()-do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do-  dflags <- getDynFlags-  gc_id <- newBlockId--  let-    Just alloc_lit = mb_alloc_lit--    bump_hp   = cmmOffsetExprB dflags hpExpr alloc_lit--    -- Sp overflow if ((old + 0) - CmmHighStack < SpLim)-    -- At the beginning of a function old + 0 = Sp-    -- See Note [Single stack check]-    sp_oflo sp_hwm =-         CmmMachOp (mo_wordULt dflags)-                  [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg)))-                             [CmmStackSlot Old 0, sp_hwm],-                   CmmReg spLimReg]--    -- Hp overflow if (Hp > HpLim)-    -- (Hp has been incremented by now)-    -- HpLim points to the LAST WORD of valid allocation space.-    hp_oflo = CmmMachOp (mo_wordUGt dflags) [hpExpr, hpLimExpr]--    alloc_n = mkAssign hpAllocReg alloc_lit--  case mb_stk_hwm of-    Nothing -> return ()-    Just stk_hwm -> tickyStackCheck-      >> (emit =<< mkCmmIfGoto' (sp_oflo stk_hwm) gc_id (Just False) )--  -- Emit new label that might potentially be a header-  -- of a self-recursive tail call.-  -- See Note [Self-recursive loop header].-  self_loop_info <- getSelfLoop-  case self_loop_info of-    Just (_, loop_header_id, _)-        | checkYield && isJust mb_stk_hwm -> emitLabel loop_header_id-    _otherwise -> return ()--  if (isJust mb_alloc_lit)-    then do-     tickyHeapCheck-     emitAssign hpReg bump_hp-     emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False)-    else do-      when (checkYield && not (gopt Opt_OmitYields dflags)) $ do-         -- Yielding if HpLim == 0-         let yielding = CmmMachOp (mo_wordEq dflags)-                                  [CmmReg hpLimReg,-                                   CmmLit (zeroCLit dflags)]-         emit =<< mkCmmIfGoto' yielding gc_id (Just False)--  tscope <- getTickScope-  emitOutOfLine gc_id-   (do_gc, tscope) -- this is expected to jump back somewhere--                -- Test for stack pointer exhaustion, then-                -- bump heap pointer, and test for heap exhaustion-                -- Note that we don't move the heap pointer unless the-                -- stack check succeeds.  Otherwise we might end up-                -- with slop at the end of the current block, which can-                -- confuse the LDV profiler.---- Note [Self-recursive loop header]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ Self-recursive loop header is required by loopification optimization (See--- Note [Self-recursive tail calls] in StgCmmExpr). We emit it if:------  1. There is information about self-loop in the FCode environment. We don't---     check the binder (first component of the self_loop_info) because we are---     certain that if the self-loop info is present then we are compiling the---     binder body. Reason: the only possible way to get here with the---     self_loop_info present is from closureCodeBody.------  2. checkYield && isJust mb_stk_hwm. checkYield tells us that it is possible---     to preempt the heap check (see #367 for motivation behind this check). It---     is True for heap checks placed at the entry to a function and---     let-no-escape heap checks but false for other heap checks (eg. in case---     alternatives or created from hand-written high-level Cmm). The second---     check (isJust mb_stk_hwm) is true for heap checks at the entry to a---     function and some heap checks created in hand-written Cmm. Otherwise it---     is Nothing. In other words the only situation when both conditions are---     true is when compiling stack and heap checks at the entry to a---     function. This is the only situation when we want to emit a self-loop---     label.
− compiler/codeGen/StgCmmHpc.hs 
@@ -1,48 +0,0 @@------------------------------------------------------------------------------------ Code generation for coverage------ (c) Galois Connections, Inc. 2006-----------------------------------------------------------------------------------module StgCmmHpc ( initHpc, mkTickBox ) where--import GhcPrelude--import StgCmmMonad--import MkGraph-import CmmExpr-import CLabel-import Module-import CmmUtils-import StgCmmUtils-import HscTypes-import DynFlags--import Control.Monad--mkTickBox :: DynFlags -> Module -> Int -> CmmAGraph-mkTickBox dflags mod n-  = mkStore tick_box (CmmMachOp (MO_Add W64)-                                [ CmmLoad tick_box b64-                                , CmmLit (CmmInt 1 W64)-                                ])-  where-    tick_box = cmmIndex dflags W64-                        (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)-                        n--initHpc :: Module -> HpcInfo -> FCode ()--- Emit top-level tables for HPC and return code to initialise-initHpc _ (NoHpcInfo {})-  = return ()-initHpc this_mod (HpcInfo tickCount _hashNo)-  = do dflags <- getDynFlags-       when (gopt Opt_Hpc dflags) $-           do emitDataLits (mkHpcTicksLabel this_mod)-                           [ (CmmInt 0 W64)-                           | _ <- take tickCount [0 :: Int ..]-                           ]-
− compiler/codeGen/StgCmmLayout.hs 
@@ -1,623 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}------------------------------------------------------------------------------------- Building info tables.------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module StgCmmLayout (-        mkArgDescr,-        emitCall, emitReturn, adjustHpBackwards,--        emitClosureProcAndInfoTable,-        emitClosureAndInfoTable,--        slowCall, directCall,--        FieldOffOrPadding(..),-        ClosureHeader(..),-        mkVirtHeapOffsets,-        mkVirtHeapOffsetsWithPadding,-        mkVirtConstrOffsets,-        mkVirtConstrSizes,-        getHpRelOffset,--        ArgRep(..), toArgRep, argRepSizeW -- re-exported from StgCmmArgRep-  ) where---#include "GhclibHsVersions.h"--import GhcPrelude hiding ((<*>))--import StgCmmClosure-import StgCmmEnv-import StgCmmArgRep -- notably: ( slowCallPattern )-import StgCmmTicky-import StgCmmMonad-import StgCmmUtils--import MkGraph-import SMRep-import BlockId-import Cmm-import CmmUtils-import CmmInfo-import CLabel-import StgSyn-import Id-import TyCon             ( PrimRep(..), primRepSizeB )-import BasicTypes        ( RepArity )-import DynFlags-import Module--import Util-import Data.List-import Outputable-import FastString-import Control.Monad-----------------------------------------------------------------------------                Call and return sequences----------------------------------------------------------------------------- | Return multiple values to the sequel------ If the sequel is @Return@------ >     return (x,y)------ If the sequel is @AssignTo [p,q]@------ >    p=x; q=y;----emitReturn :: [CmmExpr] -> FCode ReturnKind-emitReturn results-  = do { dflags    <- getDynFlags-       ; sequel    <- getSequel-       ; updfr_off <- getUpdFrameOff-       ; case sequel of-           Return ->-             do { adjustHpBackwards-                ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags)-                ; emit (mkReturn dflags (entryCode dflags e) results updfr_off)-                }-           AssignTo regs adjust ->-             do { when adjust adjustHpBackwards-                ; emitMultiAssign  regs results }-       ; return AssignedDirectly-       }----- | @emitCall conv fun args@ makes a call to the entry-code of @fun@,--- using the call/return convention @conv@, passing @args@, and--- returning the results to the current sequel.----emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ReturnKind-emitCall convs fun args-  = emitCallWithExtraStack convs fun args noExtraStack----- | @emitCallWithExtraStack conv fun args stack@ makes a call to the--- entry-code of @fun@, using the call/return convention @conv@,--- passing @args@, pushing some extra stack frames described by--- @stack@, and returning the results to the current sequel.----emitCallWithExtraStack-   :: (Convention, Convention) -> CmmExpr -> [CmmExpr]-   -> [CmmExpr] -> FCode ReturnKind-emitCallWithExtraStack (callConv, retConv) fun args extra_stack-  = do  { dflags <- getDynFlags-        ; adjustHpBackwards-        ; sequel <- getSequel-        ; updfr_off <- getUpdFrameOff-        ; case sequel of-            Return -> do-              emit $ mkJumpExtra dflags callConv fun args updfr_off extra_stack-              return AssignedDirectly-            AssignTo res_regs _ -> do-              k <- newBlockId-              let area = Young k-                  (off, _, copyin) = copyInOflow dflags retConv area res_regs []-                  copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off-                                   extra_stack-              tscope <- getTickScope-              emit (copyout <*> mkLabel k tscope <*> copyin)-              return (ReturnedTo k off)-      }---adjustHpBackwards :: FCode ()--- This function adjusts the heap pointer just before a tail call or--- return.  At a call or return, the virtual heap pointer may be less--- than the real Hp, because the latter was advanced to deal with--- the worst-case branch of the code, and we may be in a better-case--- branch.  In that case, move the real Hp *back* and retract some--- ticky allocation count.------ It *does not* deal with high-water-mark adjustment.  That's done by--- functions which allocate heap.-adjustHpBackwards-  = do  { hp_usg <- getHpUsage-        ; let rHp = realHp hp_usg-              vHp = virtHp hp_usg-              adjust_words = vHp -rHp-        ; new_hp <- getHpRelOffset vHp--        ; emit (if adjust_words == 0-                then mkNop-                else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp--        ; tickyAllocHeap False adjust_words -- ...ditto--        ; setRealHp vHp-        }-------------------------------------------------------------------------------        Making calls: directCall and slowCall------------------------------------------------------------------------------ General plan is:---   - we'll make *one* fast call, either to the function itself---     (directCall) or to stg_ap_<pat>_fast (slowCall)---     Any left-over arguments will be pushed on the stack,------     e.g. Sp[old+8]  = arg1---          Sp[old+16] = arg2---          Sp[old+32] = stg_ap_pp_info---          R2 = arg3---          R3 = arg4---          call f() return to Nothing updfr_off: 32---directCall :: Convention -> CLabel -> RepArity -> [StgArg] -> FCode ReturnKind--- (directCall f n args)--- calls f(arg1, ..., argn), and applies the result to the remaining args--- The function f has arity n, and there are guaranteed at least n args--- Both arity and args include void args-directCall conv lbl arity stg_args-  = do  { argreps <- getArgRepsAmodes stg_args-        ; direct_call "directCall" conv lbl arity argreps }---slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind--- (slowCall fun args) applies fun to args, returning the results to Sequel-slowCall fun stg_args-  = do  dflags <- getDynFlags-        argsreps <- getArgRepsAmodes stg_args-        let (rts_fun, arity) = slowCallPattern (map fst argsreps)--        (r, slow_code) <- getCodeR $ do-           r <- direct_call "slow_call" NativeNodeCall-                 (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps)-           emitComment $ mkFastString ("slow_call for " ++-                                      showSDoc dflags (ppr fun) ++-                                      " with pat " ++ unpackFS rts_fun)-           return r--        -- Note [avoid intermediate PAPs]-        let n_args = length stg_args-        if n_args > arity && optLevel dflags >= 2-           then do-             funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun-             fun_iptr <- (CmmReg . CmmLocal) `fmap`-                    assignTemp (closureInfoPtr dflags (cmmUntag dflags funv))--             -- ToDo: we could do slightly better here by reusing the-             -- continuation from the slow call, which we have in r.-             -- Also we'd like to push the continuation on the stack-             -- before the branch, so that we only get one copy of the-             -- code that saves all the live variables across the-             -- call, but that might need some improvements to the-             -- special case in the stack layout code to handle this-             -- (see Note [diamond proc point]).--             fast_code <- getCode $-                emitCall (NativeNodeCall, NativeReturn)-                  (entryCode dflags fun_iptr)-                  (nonVArgs ((P,Just funv):argsreps))--             slow_lbl <- newBlockId-             fast_lbl <- newBlockId-             is_tagged_lbl <- newBlockId-             end_lbl <- newBlockId--             let correct_arity = cmmEqWord dflags (funInfoArity dflags fun_iptr)-                                                  (mkIntExpr dflags n_args)--             tscope <- getTickScope-             emit (mkCbranch (cmmIsTagged dflags funv)-                             is_tagged_lbl slow_lbl (Just True)-                   <*> mkLabel is_tagged_lbl tscope-                   <*> mkCbranch correct_arity fast_lbl slow_lbl (Just True)-                   <*> mkLabel fast_lbl tscope-                   <*> fast_code-                   <*> mkBranch end_lbl-                   <*> mkLabel slow_lbl tscope-                   <*> slow_code-                   <*> mkLabel end_lbl tscope)-             return r--           else do-             emit slow_code-             return r----- Note [avoid intermediate PAPs]------ A slow call which needs multiple generic apply patterns will be--- almost guaranteed to create one or more intermediate PAPs when--- applied to a function that takes the correct number of arguments.--- We try to avoid this situation by generating code to test whether--- we are calling a function with the correct number of arguments--- first, i.e.:------   if (TAG(f) != 0} {  // f is not a thunk---      if (f->info.arity == n) {---         ... make a fast call to f ...---      }---   }---   ... otherwise make the slow call ...------ We *only* do this when the call requires multiple generic apply--- functions, which requires pushing extra stack frames and probably--- results in intermediate PAPs.  (I say probably, because it might be--- that we're over-applying a function, but that seems even less--- likely).------ This very rarely applies, but if it does happen in an inner loop it--- can have a severe impact on performance (#6084).------------------direct_call :: String-            -> Convention     -- e.g. NativeNodeCall or NativeDirectCall-            -> CLabel -> RepArity-            -> [(ArgRep,Maybe CmmExpr)] -> FCode ReturnKind-direct_call caller call_conv lbl arity args-  | debugIsOn && args `lengthLessThan` real_arity  -- Too few args-  = do -- Caller should ensure that there enough args!-       pprPanic "direct_call" $-            text caller <+> ppr arity <+>-            ppr lbl <+> ppr (length args) <+>-            ppr (map snd args) <+> ppr (map fst args)--  | null rest_args  -- Precisely the right number of arguments-  = emitCall (call_conv, NativeReturn) target (nonVArgs args)--  | otherwise       -- Note [over-saturated calls]-  = do dflags <- getDynFlags-       emitCallWithExtraStack (call_conv, NativeReturn)-                              target-                              (nonVArgs fast_args)-                              (nonVArgs (stack_args dflags))-  where-    target = CmmLit (CmmLabel lbl)-    (fast_args, rest_args) = splitAt real_arity args-    stack_args dflags = slowArgs dflags rest_args-    real_arity = case call_conv of-                   NativeNodeCall -> arity+1-                   _              -> arity----- When constructing calls, it is easier to keep the ArgReps and the--- CmmExprs zipped together.  However, a void argument has no--- representation, so we need to use Maybe CmmExpr (the alternative of--- using zeroCLit or even undefined would work, but would be ugly).----getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]-getArgRepsAmodes = mapM getArgRepAmode-  where getArgRepAmode arg-           | V <- rep  = return (V, Nothing)-           | otherwise = do expr <- getArgAmode (NonVoid arg)-                            return (rep, Just expr)-           where rep = toArgRep (argPrimRep arg)--nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]-nonVArgs [] = []-nonVArgs ((_,Nothing)  : args) = nonVArgs args-nonVArgs ((_,Just arg) : args) = arg : nonVArgs args--{--Note [over-saturated calls]--The natural thing to do for an over-saturated call would be to call-the function with the correct number of arguments, and then apply the-remaining arguments to the value returned, e.g.--  f a b c d   (where f has arity 2)-  -->-  r = call f(a,b)-  call r(c,d)--but this entails-  - saving c and d on the stack-  - making a continuation info table-  - at the continuation, loading c and d off the stack into regs-  - finally, call r--Note that since there are a fixed number of different r's-(e.g.  stg_ap_pp_fast), we can also pre-compile continuations-that correspond to each of them, rather than generating a fresh-one for each over-saturated call.--Not only does this generate much less code, it is faster too.  We will-generate something like:--Sp[old+16] = c-Sp[old+24] = d-Sp[old+32] = stg_ap_pp_info-call f(a,b) -- usual calling convention--For the purposes of the CmmCall node, we count this extra stack as-just more arguments that we are passing on the stack (cml_args).--}---- | 'slowArgs' takes a list of function arguments and prepares them for--- pushing on the stack for "extra" arguments to a function which requires--- fewer arguments than we currently have.-slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]-slowArgs _ [] = []-slowArgs dflags args -- careful: reps contains voids (V), but args does not-  | gopt Opt_SccProfilingOn dflags-              = save_cccs ++ this_pat ++ slowArgs dflags rest_args-  | otherwise =              this_pat ++ slowArgs dflags rest_args-  where-    (arg_pat, n)            = slowCallPattern (map fst args)-    (call_args, rest_args)  = splitAt n args--    stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat-    this_pat   = (N, Just (mkLblExpr stg_ap_pat)) : call_args-    save_cccs  = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just cccsExpr)]-    save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit "stg_restore_cccs")--------------------------------------------------------------------------------        Laying out objects on the heap and stack------------------------------------------------------------------------------ The heap always grows upwards, so hpRel is easy to compute-hpRel :: VirtualHpOffset         -- virtual offset of Hp-      -> VirtualHpOffset         -- virtual offset of The Thing-      -> WordOff                -- integer word offset-hpRel hp off = off - hp--getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr--- See Note [Virtual and real heap pointers] in StgCmmMonad-getHpRelOffset virtual_offset-  = do dflags <- getDynFlags-       hp_usg <- getHpUsage-       return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset))--data FieldOffOrPadding a-    = FieldOff (NonVoid a) -- Something that needs an offset.-               ByteOff     -- Offset in bytes.-    | Padding ByteOff  -- Length of padding in bytes.-              ByteOff  -- Offset in bytes.---- | Used to tell the various @mkVirtHeapOffsets@ functions what kind--- of header the object has.  This will be accounted for in the--- offsets of the fields returned.-data ClosureHeader-  = NoHeader-  | StdHeader-  | ThunkHeader--mkVirtHeapOffsetsWithPadding-  :: DynFlags-  -> ClosureHeader            -- What kind of header to account for-  -> [NonVoid (PrimRep, a)]   -- Things to make offsets for-  -> ( WordOff                -- Total number of words allocated-     , WordOff                -- Number of words allocated for *pointers*-     , [FieldOffOrPadding a]  -- Either an offset or padding.-     )---- Things with their offsets from start of object in order of--- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER--- First in list gets lowest offset, which is initial offset + 1.------ mkVirtHeapOffsetsWithPadding always returns boxed things with smaller offsets--- than the unboxed things--mkVirtHeapOffsetsWithPadding dflags header things =-    ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))-    ( tot_wds-    , bytesToWordsRoundUp dflags bytes_of_ptrs-    , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad-    )-  where-    hdr_words = case header of-      NoHeader -> 0-      StdHeader -> fixedHdrSizeW dflags-      ThunkHeader -> thunkHdrSize dflags-    hdr_bytes = wordsToBytes dflags hdr_words--    (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things--    (bytes_of_ptrs, ptrs_w_offsets) =-       mapAccumL computeOffset 0 ptrs-    (tot_bytes, non_ptrs_w_offsets) =-       mapAccumL computeOffset bytes_of_ptrs non_ptrs--    tot_wds = bytesToWordsRoundUp dflags tot_bytes--    final_pad_size = tot_wds * word_size - tot_bytes-    final_pad-        | final_pad_size > 0 = [(Padding final_pad_size-                                         (hdr_bytes + tot_bytes))]-        | otherwise          = []--    word_size = wORD_SIZE dflags--    computeOffset bytes_so_far nv_thing =-        (new_bytes_so_far, with_padding field_off)-      where-        (rep, thing) = fromNonVoid nv_thing--        -- Size of the field in bytes.-        !sizeB = primRepSizeB dflags rep--        -- Align the start offset (eg, 2-byte value should be 2-byte aligned).-        -- But not more than to a word.-        !align = min word_size sizeB-        !start = roundUpTo bytes_so_far align-        !padding = start - bytes_so_far--        -- Final offset is:-        --   size of header + bytes_so_far + padding-        !final_offset = hdr_bytes + bytes_so_far + padding-        !new_bytes_so_far = start + sizeB-        field_off = FieldOff (NonVoid thing) final_offset--        with_padding field_off-            | padding == 0 = [field_off]-            | otherwise    = [ Padding padding (hdr_bytes + bytes_so_far)-                             , field_off-                             ]---mkVirtHeapOffsets-  :: DynFlags-  -> ClosureHeader            -- What kind of header to account for-  -> [NonVoid (PrimRep,a)]    -- Things to make offsets for-  -> (WordOff,                -- _Total_ number of words allocated-      WordOff,                -- Number of words allocated for *pointers*-      [(NonVoid a, ByteOff)])-mkVirtHeapOffsets dflags header things =-    ( tot_wds-    , ptr_wds-    , [ (field, offset) | (FieldOff field offset) <- things_offsets ]-    )-  where-   (tot_wds, ptr_wds, things_offsets) =-       mkVirtHeapOffsetsWithPadding dflags header things---- | Just like mkVirtHeapOffsets, but for constructors-mkVirtConstrOffsets-  :: DynFlags -> [NonVoid (PrimRep, a)]-  -> (WordOff, WordOff, [(NonVoid a, ByteOff)])-mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags StdHeader---- | Just like mkVirtConstrOffsets, but used when we don't have the actual--- arguments. Useful when e.g. generating info tables; we just need to know--- sizes of pointer and non-pointer fields.-mkVirtConstrSizes :: DynFlags -> [NonVoid PrimRep] -> (WordOff, WordOff)-mkVirtConstrSizes dflags field_reps-  = (tot_wds, ptr_wds)-  where-    (tot_wds, ptr_wds, _) =-       mkVirtConstrOffsets dflags-         (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps)---------------------------------------------------------------------------------        Making argument descriptors------  An argument descriptor describes the layout of args on the stack,---  both for         * GC (stack-layout) purposes, and---                * saving/restoring registers when a heap-check fails------ Void arguments aren't important, therefore (contrast constructSlowCall)--------------------------------------------------------------------------------- bring in ARG_P, ARG_N, etc.-#include "rts/storage/FunTypes.h"--mkArgDescr :: DynFlags -> [Id] -> ArgDescr-mkArgDescr dflags args-  = let arg_bits = argBits dflags arg_reps-        arg_reps = filter isNonV (map idArgRep args)-           -- Getting rid of voids eases matching of standard patterns-    in case stdPattern arg_reps of-         Just spec_id -> ArgSpec spec_id-         Nothing      -> ArgGen  arg_bits--argBits :: DynFlags -> [ArgRep] -> [Bool]        -- True for non-ptr, False for ptr-argBits _      []           = []-argBits dflags (P   : args) = False : argBits dflags args-argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True)-                    ++ argBits dflags args-------------------------stdPattern :: [ArgRep] -> Maybe Int-stdPattern reps-  = case reps of-        []    -> Just ARG_NONE        -- just void args, probably-        [N]   -> Just ARG_N-        [P]   -> Just ARG_P-        [F]   -> Just ARG_F-        [D]   -> Just ARG_D-        [L]   -> Just ARG_L-        [V16] -> Just ARG_V16-        [V32] -> Just ARG_V32-        [V64] -> Just ARG_V64--        [N,N] -> Just ARG_NN-        [N,P] -> Just ARG_NP-        [P,N] -> Just ARG_PN-        [P,P] -> Just ARG_PP--        [N,N,N] -> Just ARG_NNN-        [N,N,P] -> Just ARG_NNP-        [N,P,N] -> Just ARG_NPN-        [N,P,P] -> Just ARG_NPP-        [P,N,N] -> Just ARG_PNN-        [P,N,P] -> Just ARG_PNP-        [P,P,N] -> Just ARG_PPN-        [P,P,P] -> Just ARG_PPP--        [P,P,P,P]     -> Just ARG_PPPP-        [P,P,P,P,P]   -> Just ARG_PPPPP-        [P,P,P,P,P,P] -> Just ARG_PPPPPP--        _ -> Nothing---------------------------------------------------------------------------------        Generating the info table and code for a closure--------------------------------------------------------------------------------- Here we make an info table of type 'CmmInfo'.  The concrete--- representation as a list of 'CmmAddr' is handled later--- in the pipeline by 'cmmToRawCmm'.--- When loading the free variables, a function closure pointer may be tagged,--- so we must take it into account.--emitClosureProcAndInfoTable :: Bool                    -- top-level?-                            -> Id                      -- name of the closure-                            -> LambdaFormInfo-                            -> CmmInfoTable-                            -> [NonVoid Id]            -- incoming arguments-                            -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body-                            -> FCode ()-emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body- = do   { dflags <- getDynFlags-        -- Bind the binder itself, but only if it's not a top-level-        -- binding. We need non-top let-bindings to refer to the-        -- top-level binding, which this binding would incorrectly shadow.-        ; node <- if top_lvl then return $ idToReg dflags (NonVoid bndr)-                  else bindToReg (NonVoid bndr) lf_info-        ; let node_points = nodeMustPointToIt dflags lf_info-        ; arg_regs <- bindArgsToRegs args-        ; let args' = if node_points then (node : arg_regs) else arg_regs-              conv  = if nodeMustPointToIt dflags lf_info then NativeNodeCall-                                                          else NativeDirectCall-              (offset, _, _) = mkCallEntry dflags conv args' []-        ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs)-        }---- Data constructors need closures, but not with all the argument handling--- needed for functions. The shared part goes here.-emitClosureAndInfoTable ::-  CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()-emitClosureAndInfoTable info_tbl conv args body-  = do { (_, blks) <- getCodeScoped body-       ; let entry_lbl = toEntryLbl (cit_lbl info_tbl)-       ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks-       }
− compiler/codeGen/StgCmmMonad.hs 
@@ -1,876 +0,0 @@-{-# LANGUAGE GADTs #-}------------------------------------------------------------------------------------- Monad for Stg to C-- code generation------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module StgCmmMonad (-        FCode,        -- type--        initC, runC, fixC,-        newUnique,--        emitLabel,--        emit, emitDecl, emitProc,-        emitProcWithConvention, emitProcWithStackFrame,-        emitOutOfLine, emitAssign, emitStore,-        emitComment, emitTick, emitUnwind,--        getCmm, aGraphToGraph,-        getCodeR, getCode, getCodeScoped, getHeapUsage,--        mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,-        mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto',--        mkCall, mkCmmCall,--        forkClosureBody, forkLneBody, forkAlts, forkAltPair, codeOnly,--        ConTagZ,--        Sequel(..), ReturnKind(..),-        withSequel, getSequel,--        setTickyCtrLabel, getTickyCtrLabel,-        tickScope, getTickScope,--        withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,--        HeapUsage(..), VirtualHpOffset,        initHpUsage,-        getHpUsage,  setHpUsage, heapHWM,-        setVirtHp, getVirtHp, setRealHp,--        getModuleName,--        -- ideally we wouldn't export these, but some other modules access internal state-        getState, setState, getSelfLoop, withSelfLoop, getInfoDown, getDynFlags, getThisPackage,--        -- more localised access to monad state-        CgIdInfo(..),-        getBinds, setBinds,--        -- out of general friendliness, we also export ...-        CgInfoDownwards(..), CgState(..)        -- non-abstract-    ) where--import GhcPrelude hiding( sequence, succ )--import Cmm-import StgCmmClosure-import DynFlags-import Hoopl.Collections-import MkGraph-import BlockId-import CLabel-import SMRep-import Module-import Id-import VarEnv-import OrdList-import BasicTypes( ConTagZ )-import Unique-import UniqSupply-import FastString-import Outputable-import Util--import Control.Monad-import Data.List--------------------------------------------------------------- The FCode monad and its types------ FCode is the monad plumbed through the Stg->Cmm code generator, and--- the Cmm parser.  It contains the following things:------  - A writer monad, collecting:---    - code for the current function, in the form of a CmmAGraph.---      The function "emit" appends more code to this.---    - the top-level CmmDecls accumulated so far------  - A state monad with:---    - the local bindings in scope---    - the current heap usage---    - a UniqSupply------  - A reader monad, for CgInfoDownwards, containing---    - DynFlags,---    - the current Module---    - the update-frame offset---    - the ticky counter label---    - the Sequel (the continuation to return to)---    - the self-recursive tail call information------------------------------------------------------------newtype FCode a = FCode { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) }--instance Functor FCode where-    fmap f (FCode g) = FCode $ \i s -> case g i s of (a, s') -> (f a, s')--instance Applicative FCode where-    pure val = FCode (\_info_down state -> (val, state))-    {-# INLINE pure #-}-    (<*>) = ap--instance Monad FCode where-    FCode m >>= k = FCode $-        \info_down state ->-            case m info_down state of-              (m_result, new_state) ->-                 case k m_result of-                   FCode kcode -> kcode info_down new_state-    {-# INLINE (>>=) #-}--instance MonadUnique FCode where-  getUniqueSupplyM = cgs_uniqs <$> getState-  getUniqueM = FCode $ \_ st ->-    let (u, us') = takeUniqFromSupply (cgs_uniqs st)-    in (u, st { cgs_uniqs = us' })--initC :: IO CgState-initC  = do { uniqs <- mkSplitUniqSupply 'c'-            ; return (initCgState uniqs) }--runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)-runC dflags mod st fcode = doFCode fcode (initCgInfoDown dflags mod) st--fixC :: (a -> FCode a) -> FCode a-fixC fcode = FCode $-    \info_down state -> let (v, s) = doFCode (fcode v) info_down state-                        in (v, s)-------------------------------------------------------------        The code generator environment------------------------------------------------------------- This monadery has some information that it only passes--- *downwards*, as well as some ``state'' which is modified--- as we go along.--data CgInfoDownwards        -- information only passed *downwards* by the monad-  = MkCgInfoDown {-        cgd_dflags    :: DynFlags,-        cgd_mod       :: Module,            -- Module being compiled-        cgd_updfr_off :: UpdFrameOffset,    -- Size of current update frame-        cgd_ticky     :: CLabel,            -- Current destination for ticky counts-        cgd_sequel    :: Sequel,            -- What to do at end of basic block-        cgd_self_loop :: Maybe SelfLoopInfo,-- Which tail calls can be compiled-                                            -- as local jumps? See Note-                                            -- [Self-recursive tail calls] in-                                            -- StgCmmExpr-        cgd_tick_scope:: CmmTickScope       -- Tick scope for new blocks & ticks-  }--type CgBindings = IdEnv CgIdInfo--data CgIdInfo-  = CgIdInfo-        { cg_id :: Id   -- Id that this is the info for-                        -- Can differ from the Id at occurrence sites by-                        -- virtue of being externalised, for splittable C-                        -- See Note [Externalise when splitting]-        , cg_lf  :: LambdaFormInfo-        , cg_loc :: CgLoc                     -- CmmExpr for the *tagged* value-        }---- Note [Externalise when splitting]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- If we're splitting the object with -fsplit-objs, we need to--- externalise *all* the top-level names, and then make sure we only--- use the externalised one in any C label we use which refers to this--- name.--instance Outputable CgIdInfo where-  ppr (CgIdInfo { cg_id = id, cg_loc = loc })-    = ppr id <+> text "-->" <+> ppr loc---- Sequel tells what to do with the result of this expression-data Sequel-  = Return              -- Return result(s) to continuation found on the stack.--  | AssignTo-        [LocalReg]      -- Put result(s) in these regs and fall through-                        -- NB: no void arguments here-                        ---        Bool            -- Should we adjust the heap pointer back to-                        -- recover space that's unused on this path?-                        -- We need to do this only if the expression-                        -- may allocate (e.g. it's a foreign call or-                        -- allocating primOp)--instance Outputable Sequel where-    ppr Return = text "Return"-    ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b---- See Note [sharing continuations] below-data ReturnKind-  = AssignedDirectly-  | ReturnedTo BlockId ByteOff---- Note [sharing continuations]------ ReturnKind says how the expression being compiled returned its--- results: either by assigning directly to the registers specified--- by the Sequel, or by returning to a continuation that does the--- assignments.  The point of this is we might be able to re-use the--- continuation in a subsequent heap-check.  Consider:------    case f x of z---      True  -> <True code>---      False -> <False code>------ Naively we would generate------    R2 = x   -- argument to f---    Sp[young(L1)] = L1---    call f returns to L1---  L1:---    z = R1---    if (z & 1) then Ltrue else Lfalse---  Ltrue:---    Hp = Hp + 24---    if (Hp > HpLim) then L4 else L7---  L4:---    HpAlloc = 24---    goto L5---  L5:---    R1 = z---    Sp[young(L6)] = L6---    call stg_gc_unpt_r1 returns to L6---  L6:---    z = R1---    goto L1---  L7:---    <True code>---  Lfalse:---    <False code>------ We want the gc call in L4 to return to L1, and discard L6.  Note--- that not only can we share L1 and L6, but the assignment of the--- return address in L4 is unnecessary because the return address for--- L1 is already on the stack.  We used to catch the sharing of L1 and--- L6 in the common-block-eliminator, but not the unnecessary return--- address assignment.------ Since this case is so common I decided to make it more explicit and--- robust by programming the sharing directly, rather than relying on--- the common-block eliminator to catch it.  This makes--- common-block-elimination an optional optimisation, and furthermore--- generates less code in the first place that we have to subsequently--- clean up.------ There are some rarer cases of common blocks that we don't catch--- this way, but that's ok.  Common-block-elimination is still available--- to catch them when optimisation is enabled.  Some examples are:------   - when both the True and False branches do a heap check, we---     can share the heap-check failure code L4a and maybe L4------   - in a case-of-case, there might be multiple continuations that---     we can common up.------ It is always safe to use AssignedDirectly.  Expressions that jump--- to the continuation from multiple places (e.g. case expressions)--- fall back to AssignedDirectly.------initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards-initCgInfoDown dflags mod-  = MkCgInfoDown { cgd_dflags    = dflags-                 , cgd_mod       = mod-                 , cgd_updfr_off = initUpdFrameOff dflags-                 , cgd_ticky     = mkTopTickyCtrLabel-                 , cgd_sequel    = initSequel-                 , cgd_self_loop = Nothing-                 , cgd_tick_scope= GlobalScope }--initSequel :: Sequel-initSequel = Return--initUpdFrameOff :: DynFlags -> UpdFrameOffset-initUpdFrameOff dflags = widthInBytes (wordWidth dflags) -- space for the RA--------------------------------------------------------------        The code generator state-----------------------------------------------------------data CgState-  = MkCgState {-     cgs_stmts :: CmmAGraph,          -- Current procedure--     cgs_tops  :: OrdList CmmDecl,-        -- Other procedures and data blocks in this compilation unit-        -- Both are ordered only so that we can-        -- reduce forward references, when it's easy to do so--     cgs_binds :: CgBindings,--     cgs_hp_usg  :: HeapUsage,--     cgs_uniqs :: UniqSupply }--data HeapUsage   -- See Note [Virtual and real heap pointers]-  = HeapUsage {-        virtHp :: VirtualHpOffset,       -- Virtual offset of highest-allocated word-                                         --   Incremented whenever we allocate-        realHp :: VirtualHpOffset        -- realHp: Virtual offset of real heap ptr-                                         --   Used in instruction addressing modes-    }--type VirtualHpOffset = WordOff---{- Note [Virtual and real heap pointers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The code generator can allocate one or more objects contiguously, performing-one heap check to cover allocation of all the objects at once.  Let's call-this little chunk of heap space an "allocation chunk".  The code generator-will emit code to-  * Perform a heap-exhaustion check-  * Move the heap pointer to the end of the allocation chunk-  * Allocate multiple objects within the chunk--The code generator uses VirtualHpOffsets to address words within a-single allocation chunk; these start at one and increase positively.-The first word of the chunk has VirtualHpOffset=1, the second has-VirtualHpOffset=2, and so on.-- * The field realHp tracks (the VirtualHpOffset) where the real Hp-   register is pointing.  Typically it'll be pointing to the end of the-   allocation chunk.-- * The field virtHp gives the VirtualHpOffset of the highest-allocated-   word so far.  It starts at zero (meaning no word has been allocated),-   and increases whenever an object is allocated.--The difference between realHp and virtHp gives the offset from the-real Hp register of a particular word in the allocation chunk. This-is what getHpRelOffset does.  Since the returned offset is relative-to the real Hp register, it is valid only until you change the real-Hp register.  (Changing virtHp doesn't matter.)--}---initCgState :: UniqSupply -> CgState-initCgState uniqs-  = MkCgState { cgs_stmts  = mkNop-              , cgs_tops   = nilOL-              , cgs_binds  = emptyVarEnv-              , cgs_hp_usg = initHpUsage-              , cgs_uniqs  = uniqs }--stateIncUsage :: CgState -> CgState -> CgState--- stateIncUsage@ e1 e2 incorporates in e1--- the heap high water mark found in e2.-stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg })-     = s1 { cgs_hp_usg  = cgs_hp_usg  s1 `maxHpHw`  virtHp hp_usg }-       `addCodeBlocksFrom` s2--addCodeBlocksFrom :: CgState -> CgState -> CgState--- Add code blocks from the latter to the former--- (The cgs_stmts will often be empty, but not always; see codeOnly)-s1 `addCodeBlocksFrom` s2-  = s1 { cgs_stmts = cgs_stmts s1 MkGraph.<*> cgs_stmts s2,-         cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }----- The heap high water mark is the larger of virtHp and hwHp.  The latter is--- only records the high water marks of forked-off branches, so to find the--- heap high water mark you have to take the max of virtHp and hwHp.  Remember,--- virtHp never retreats!------ Note Jan 04: ok, so why do we only look at the virtual Hp??--heapHWM :: HeapUsage -> VirtualHpOffset-heapHWM = virtHp--initHpUsage :: HeapUsage-initHpUsage = HeapUsage { virtHp = 0, realHp = 0 }--maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage-hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }------------------------------------------------------------- Operators for getting and setting the state and "info_down".-----------------------------------------------------------getState :: FCode CgState-getState = FCode $ \_info_down state -> (state, state)--setState :: CgState -> FCode ()-setState state = FCode $ \_info_down _ -> ((), state)--getHpUsage :: FCode HeapUsage-getHpUsage = do-        state <- getState-        return $ cgs_hp_usg state--setHpUsage :: HeapUsage -> FCode ()-setHpUsage new_hp_usg = do-        state <- getState-        setState $ state {cgs_hp_usg = new_hp_usg}--setVirtHp :: VirtualHpOffset -> FCode ()-setVirtHp new_virtHp-  = do  { hp_usage <- getHpUsage-        ; setHpUsage (hp_usage {virtHp = new_virtHp}) }--getVirtHp :: FCode VirtualHpOffset-getVirtHp-  = do  { hp_usage <- getHpUsage-        ; return (virtHp hp_usage) }--setRealHp ::  VirtualHpOffset -> FCode ()-setRealHp new_realHp-  = do  { hp_usage <- getHpUsage-        ; setHpUsage (hp_usage {realHp = new_realHp}) }--getBinds :: FCode CgBindings-getBinds = do-        state <- getState-        return $ cgs_binds state--setBinds :: CgBindings -> FCode ()-setBinds new_binds = do-        state <- getState-        setState $ state {cgs_binds = new_binds}--withState :: FCode a -> CgState -> FCode (a,CgState)-withState (FCode fcode) newstate = FCode $ \info_down state ->-  case fcode info_down newstate of-    (retval, state2) -> ((retval,state2), state)--newUniqSupply :: FCode UniqSupply-newUniqSupply = do-        state <- getState-        let (us1, us2) = splitUniqSupply (cgs_uniqs state)-        setState $ state { cgs_uniqs = us1 }-        return us2--newUnique :: FCode Unique-newUnique = do-        state <- getState-        let (u,us') = takeUniqFromSupply (cgs_uniqs state)-        setState $ state { cgs_uniqs = us' }-        return u---------------------getInfoDown :: FCode CgInfoDownwards-getInfoDown = FCode $ \info_down state -> (info_down,state)--getSelfLoop :: FCode (Maybe SelfLoopInfo)-getSelfLoop = do-        info_down <- getInfoDown-        return $ cgd_self_loop info_down--withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a-withSelfLoop self_loop code = do-        info_down <- getInfoDown-        withInfoDown code (info_down {cgd_self_loop = Just self_loop})--instance HasDynFlags FCode where-    getDynFlags = liftM cgd_dflags getInfoDown--getThisPackage :: FCode UnitId-getThisPackage = liftM thisPackage getDynFlags--withInfoDown :: FCode a -> CgInfoDownwards -> FCode a-withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state---- ------------------------------------------------------------------------------- Get the current module name--getModuleName :: FCode Module-getModuleName = do { info <- getInfoDown; return (cgd_mod info) }---- ------------------------------------------------------------------------------- Get/set the end-of-block info--withSequel :: Sequel -> FCode a -> FCode a-withSequel sequel code-  = do  { info  <- getInfoDown-        ; withInfoDown code (info {cgd_sequel = sequel, cgd_self_loop = Nothing }) }--getSequel :: FCode Sequel-getSequel = do  { info <- getInfoDown-                ; return (cgd_sequel info) }---- ------------------------------------------------------------------------------- Get/set the size of the update frame---- We keep track of the size of the update frame so that we--- can set the stack pointer to the proper address on return--- (or tail call) from the closure.--- There should be at most one update frame for each closure.--- Note: I'm including the size of the original return address--- in the size of the update frame -- hence the default case on `get'.--withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a-withUpdFrameOff size code-  = do  { info  <- getInfoDown-        ; withInfoDown code (info {cgd_updfr_off = size }) }--getUpdFrameOff :: FCode UpdFrameOffset-getUpdFrameOff-  = do  { info  <- getInfoDown-        ; return $ cgd_updfr_off info }---- ------------------------------------------------------------------------------- Get/set the current ticky counter label--getTickyCtrLabel :: FCode CLabel-getTickyCtrLabel = do-        info <- getInfoDown-        return (cgd_ticky info)--setTickyCtrLabel :: CLabel -> FCode a -> FCode a-setTickyCtrLabel ticky code = do-        info <- getInfoDown-        withInfoDown code (info {cgd_ticky = ticky})---- ------------------------------------------------------------------------------- Manage tick scopes---- | The current tick scope. We will assign this to generated blocks.-getTickScope :: FCode CmmTickScope-getTickScope = do-        info <- getInfoDown-        return (cgd_tick_scope info)---- | Places blocks generated by the given code into a fresh--- (sub-)scope. This will make sure that Cmm annotations in our scope--- will apply to the Cmm blocks generated therein - but not the other--- way around.-tickScope :: FCode a -> FCode a-tickScope code = do-        info <- getInfoDown-        if debugLevel (cgd_dflags info) == 0 then code else do-          u <- newUnique-          let scope' = SubScope u (cgd_tick_scope info)-          withInfoDown code info{ cgd_tick_scope = scope' }--------------------------------------------------------------                 Forking-----------------------------------------------------------forkClosureBody :: FCode () -> FCode ()--- forkClosureBody compiles body_code in environment where:---   - sequel, update stack frame and self loop info are---     set to fresh values---   - state is set to a fresh value, except for local bindings---     that are passed in unchanged. It's up to the enclosed code to---     re-bind the free variables to a field of the closure.--forkClosureBody body_code-  = do  { dflags <- getDynFlags-        ; info   <- getInfoDown-        ; us     <- newUniqSupply-        ; state  <- getState-        ; let body_info_down = info { cgd_sequel    = initSequel-                                    , cgd_updfr_off = initUpdFrameOff dflags-                                    , cgd_self_loop = Nothing }-              fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }-              ((),fork_state_out) = doFCode body_code body_info_down fork_state_in-        ; setState $ state `addCodeBlocksFrom` fork_state_out }--forkLneBody :: FCode a -> FCode a--- 'forkLneBody' takes a body of let-no-escape binding and compiles--- it in the *current* environment, returning the graph thus constructed.------ The current environment is passed on completely unchanged to--- the successor.  In particular, any heap usage from the enclosed--- code is discarded; it should deal with its own heap consumption.-forkLneBody body_code-  = do  { info_down <- getInfoDown-        ; us        <- newUniqSupply-        ; state     <- getState-        ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }-              (result, fork_state_out) = doFCode body_code info_down fork_state_in-        ; setState $ state `addCodeBlocksFrom` fork_state_out-        ; return result }--codeOnly :: FCode () -> FCode ()--- Emit any code from the inner thing into the outer thing--- Do not affect anything else in the outer state--- Used in almost-circular code to prevent false loop dependencies-codeOnly body_code-  = do  { info_down <- getInfoDown-        ; us        <- newUniqSupply-        ; state     <- getState-        ; let   fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state-                                                 , cgs_hp_usg  = cgs_hp_usg state }-                ((), fork_state_out) = doFCode body_code info_down fork_state_in-        ; setState $ state `addCodeBlocksFrom` fork_state_out }--forkAlts :: [FCode a] -> FCode [a]--- (forkAlts' bs d) takes fcodes 'bs' for the branches of a 'case', and--- an fcode for the default case 'd', and compiles each in the current--- environment.  The current environment is passed on unmodified, except--- that the virtual Hp is moved on to the worst virtual Hp for the branches--forkAlts branch_fcodes-  = do  { info_down <- getInfoDown-        ; us <- newUniqSupply-        ; state <- getState-        ; let compile us branch-                = (us2, doFCode branch info_down branch_state)-                where-                  (us1,us2) = splitUniqSupply us-                  branch_state = (initCgState us1) {-                                        cgs_binds  = cgs_binds state-                                      , cgs_hp_usg = cgs_hp_usg state }-              (_us, results) = mapAccumL compile us branch_fcodes-              (branch_results, branch_out_states) = unzip results-        ; setState $ foldl' stateIncUsage state branch_out_states-                -- NB foldl.  state is the *left* argument to stateIncUsage-        ; return branch_results }--forkAltPair :: FCode a -> FCode a -> FCode (a,a)--- Most common use of 'forkAlts'; having this helper function avoids--- accidental use of failible pattern-matches in @do@-notation-forkAltPair x y = do-  xy' <- forkAlts [x,y]-  case xy' of-    [x',y'] -> return (x',y')-    _ -> panic "forkAltPair"---- collect the code emitted by an FCode computation-getCodeR :: FCode a -> FCode (a, CmmAGraph)-getCodeR fcode-  = do  { state1 <- getState-        ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop })-        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }-        ; return (a, cgs_stmts state2) }--getCode :: FCode a -> FCode CmmAGraph-getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts }---- | Generate code into a fresh tick (sub-)scope and gather generated code-getCodeScoped :: FCode a -> FCode (a, CmmAGraphScoped)-getCodeScoped fcode-  = do  { state1 <- getState-        ; ((a, tscope), state2) <--            tickScope $-            flip withState state1 { cgs_stmts = mkNop } $-            do { a   <- fcode-               ; scp <- getTickScope-               ; return (a, scp) }-        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }-        ; return (a, (cgs_stmts state2, tscope)) }----- 'getHeapUsage' applies a function to the amount of heap that it uses.--- It initialises the heap usage to zeros, and passes on an unchanged--- heap usage.------ It is usually a prelude to performing a GC check, so everything must--- be in a tidy and consistent state.------ Note the slightly subtle fixed point behaviour needed here--getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a-getHeapUsage fcode-  = do  { info_down <- getInfoDown-        ; state <- getState-        ; let   fstate_in = state { cgs_hp_usg  = initHpUsage }-                (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in-                hp_hw = heapHWM (cgs_hp_usg fstate_out)        -- Loop here!--        ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }-        ; return r }---- ------------------------------------------------------------------------------- Combinators for emitting code--emitCgStmt :: CgStmt -> FCode ()-emitCgStmt stmt-  = do  { state <- getState-        ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }-        }--emitLabel :: BlockId -> FCode ()-emitLabel id = do tscope <- getTickScope-                  emitCgStmt (CgLabel id tscope)--emitComment :: FastString -> FCode ()-emitComment s-  | debugIsOn = emitCgStmt (CgStmt (CmmComment s))-  | otherwise = return ()--emitTick :: CmmTickish -> FCode ()-emitTick = emitCgStmt . CgStmt . CmmTick--emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode ()-emitUnwind regs = do-  dflags <- getDynFlags-  when (debugLevel dflags > 0) $ do-     emitCgStmt $ CgStmt $ CmmUnwind regs--emitAssign :: CmmReg  -> CmmExpr -> FCode ()-emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))--emitStore :: CmmExpr  -> CmmExpr -> FCode ()-emitStore l r = emitCgStmt (CgStmt (CmmStore l r))--emit :: CmmAGraph -> FCode ()-emit ag-  = do  { state <- getState-        ; setState $ state { cgs_stmts = cgs_stmts state MkGraph.<*> ag } }--emitDecl :: CmmDecl -> FCode ()-emitDecl decl-  = do  { state <- getState-        ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }--emitOutOfLine :: BlockId -> CmmAGraphScoped -> FCode ()-emitOutOfLine l (stmts, tscope) = emitCgStmt (CgFork l stmts tscope)--emitProcWithStackFrame-   :: Convention                        -- entry convention-   -> Maybe CmmInfoTable                -- info table?-   -> CLabel                            -- label for the proc-   -> [CmmFormal]                       -- stack frame-   -> [CmmFormal]                       -- arguments-   -> CmmAGraphScoped                   -- code-   -> Bool                              -- do stack layout?-   -> FCode ()--emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False-  = do  { dflags <- getDynFlags-        ; emitProc_ mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False-        }-emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True-        -- do layout-  = do  { dflags <- getDynFlags-        ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args-              graph' = entry MkGraph.<*> graph-        ; emitProc_ mb_info lbl live (graph', tscope) offset True-        }-emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame"--emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel-                       -> [CmmFormal]-                       -> CmmAGraphScoped-                       -> FCode ()-emitProcWithConvention conv mb_info lbl args blocks-  = emitProcWithStackFrame conv mb_info lbl [] args blocks True--emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped-         -> Int -> FCode ()-emitProc  mb_info lbl live blocks offset- = emitProc_ mb_info lbl live blocks offset True--emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped-          -> Int -> Bool -> FCode ()-emitProc_ mb_info lbl live blocks offset do_layout-  = do  { dflags <- getDynFlags-        ; l <- newBlockId-        ; let-              blks = labelAGraph l blocks--              infos | Just info <- mb_info = mapSingleton (g_entry blks) info-                    | otherwise            = mapEmpty--              sinfo = StackInfo { arg_space = offset-                                , updfr_space = Just (initUpdFrameOff dflags)-                                , do_layout = do_layout }--              tinfo = TopInfo { info_tbls = infos-                              , stack_info=sinfo}--              proc_block = CmmProc tinfo lbl live blks--        ; state <- getState-        ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }--getCmm :: FCode () -> FCode CmmGroup--- Get all the CmmTops (there should be no stmts)--- Return a single Cmm which may be split from other Cmms by--- object splitting (at a later stage)-getCmm code-  = do  { state1 <- getState-        ; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })-        ; setState $ state2 { cgs_tops = cgs_tops state1 }-        ; return (fromOL (cgs_tops state2)) }---mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph-mkCmmIfThenElse e tbranch fbranch = mkCmmIfThenElse' e tbranch fbranch Nothing--mkCmmIfThenElse' :: CmmExpr -> CmmAGraph -> CmmAGraph-                 -> Maybe Bool -> FCode CmmAGraph-mkCmmIfThenElse' e tbranch fbranch likely = do-  tscp  <- getTickScope-  endif <- newBlockId-  tid   <- newBlockId-  fid   <- newBlockId--  let-    (test, then_, else_, likely') = case likely of-      Just False | Just e' <- maybeInvertCmmExpr e-        -- currently NCG doesn't know about likely-        -- annotations. We manually switch then and-        -- else branch so the likely false branch-        -- becomes a fallthrough.-        -> (e', fbranch, tbranch, Just True)-      _ -> (e, tbranch, fbranch, likely)--  return $ catAGraphs [ mkCbranch test tid fid likely'-                      , mkLabel tid tscp, then_, mkBranch endif-                      , mkLabel fid tscp, else_, mkLabel endif tscp ]--mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph-mkCmmIfGoto e tid = mkCmmIfGoto' e tid Nothing--mkCmmIfGoto' :: CmmExpr -> BlockId -> Maybe Bool -> FCode CmmAGraph-mkCmmIfGoto' e tid l = do-  endif <- newBlockId-  tscp  <- getTickScope-  return $ catAGraphs [ mkCbranch e tid endif l, mkLabel endif tscp ]--mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph-mkCmmIfThen e tbranch = mkCmmIfThen' e tbranch Nothing--mkCmmIfThen' :: CmmExpr -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph-mkCmmIfThen' e tbranch l = do-  endif <- newBlockId-  tid   <- newBlockId-  tscp  <- getTickScope-  return $ catAGraphs [ mkCbranch e tid endif l-                      , mkLabel tid tscp, tbranch, mkLabel endif tscp ]--mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmExpr]-       -> UpdFrameOffset -> [CmmExpr] -> FCode CmmAGraph-mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do-  dflags <- getDynFlags-  k      <- newBlockId-  tscp   <- getTickScope-  let area = Young k-      (off, _, copyin) = copyInOflow dflags retConv area results []-      copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack-  return $ catAGraphs [copyout, mkLabel k tscp, copyin]--mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset-          -> FCode CmmAGraph-mkCmmCall f results actuals updfr_off-   = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off []----- ------------------------------------------------------------------------------- turn CmmAGraph into CmmGraph, for making a new proc.--aGraphToGraph :: CmmAGraphScoped -> FCode CmmGraph-aGraphToGraph stmts-  = do  { l <- newBlockId-        ; return (labelAGraph l stmts) }
− compiler/codeGen/StgCmmPrim.hs 
@@ -1,2545 +0,0 @@-{-# LANGUAGE CPP #-}--- emitPrimOp is quite large-{-# OPTIONS_GHC -fmax-pmcheck-iterations=4000000 #-}------------------------------------------------------------------------------------ Stg to C--: primitive operations------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module StgCmmPrim (-   cgOpApp,-   cgPrimOp, -- internal(ish), used by cgCase to get code for a-             -- comparison without also turning it into a Bool.-   shouldInlinePrimOp- ) where--#include "GhclibHsVersions.h"--import GhcPrelude hiding ((<*>))--import StgCmmLayout-import StgCmmForeign-import StgCmmEnv-import StgCmmMonad-import StgCmmUtils-import StgCmmTicky-import StgCmmHeap-import StgCmmProf ( costCentreFrom )--import DynFlags-import Platform-import BasicTypes-import BlockId-import MkGraph-import StgSyn-import Cmm-import Type     ( Type, tyConAppTyCon )-import TyCon-import CLabel-import CmmUtils-import PrimOp-import SMRep-import FastString-import Outputable-import Util--import Data.Bits ((.&.), bit)-import Control.Monad (liftM, when, unless)-----------------------------------------------------------------------------      Primitive operations and foreign calls---------------------------------------------------------------------------{- Note [Foreign call results]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~-A foreign call always returns an unboxed tuple of results, one-of which is the state token.  This seems to happen even for pure-calls.--Even if we returned a single result for pure calls, it'd still be-right to wrap it in a singleton unboxed tuple, because the result-might be a Haskell closure pointer, we don't want to evaluate it. -}-------------------------------------cgOpApp :: StgOp        -- The op-        -> [StgArg]     -- Arguments-        -> Type         -- Result type (always an unboxed tuple)-        -> FCode ReturnKind---- Foreign calls-cgOpApp (StgFCallOp fcall _) stg_args res_ty-  = cgForeignCall fcall stg_args res_ty-      -- Note [Foreign call results]---- tagToEnum# is special: we need to pull the constructor--- out of the table, and perform an appropriate return.--cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty-  = ASSERT(isEnumerationTyCon tycon)-    do  { dflags <- getDynFlags-        ; args' <- getNonVoidArgAmodes [arg]-        ; let amode = case args' of [amode] -> amode-                                    _ -> panic "TagToEnumOp had void arg"-        ; emitReturn [tagToClosure dflags tycon amode] }-   where-          -- If you're reading this code in the attempt to figure-          -- out why the compiler panic'ed here, it is probably because-          -- you used tagToEnum# in a non-monomorphic setting, e.g.,-          --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#-          -- That won't work.-        tycon = tyConAppTyCon res_ty--cgOpApp (StgPrimOp primop) args res_ty = do-    dflags <- getDynFlags-    cmm_args <- getNonVoidArgAmodes args-    case shouldInlinePrimOp dflags primop cmm_args of-        Nothing -> do  -- out-of-line-          let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))-          emitCall (NativeNodeCall, NativeReturn) fun cmm_args--        Just f  -- inline-          | ReturnsPrim VoidRep <- result_info-          -> do f []-                emitReturn []--          | ReturnsPrim rep <- result_info-          -> do dflags <- getDynFlags-                res <- newTemp (primRepCmmType dflags rep)-                f [res]-                emitReturn [CmmReg (CmmLocal res)]--          | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon-          -> do (regs, _hints) <- newUnboxedTupleRegs res_ty-                f regs-                emitReturn (map (CmmReg . CmmLocal) regs)--          | otherwise -> panic "cgPrimop"-          where-             result_info = getPrimOpResultInfo primop--cgOpApp (StgPrimCallOp primcall) args _res_ty-  = do  { cmm_args <- getNonVoidArgAmodes args-        ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))-        ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }---- | Interpret the argument as an unsigned value, assuming the value--- is given in two-complement form in the given width.------ Example: @asUnsigned W64 (-1)@ is 18446744073709551615.------ This function is used to work around the fact that many array--- primops take Int# arguments, but we interpret them as unsigned--- quantities in the code gen. This means that we have to be careful--- every time we work on e.g. a CmmInt literal that corresponds to the--- array size, as it might contain a negative Integer value if the--- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int#--- literal.-asUnsigned :: Width -> Integer -> Integer-asUnsigned w n = n .&. (bit (widthInBits w) - 1)---- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use---     ByteOff (or some other fixed width signed type) to represent---     array sizes or indices. This means that these will overflow for---     large enough sizes.---- | Decide whether an out-of-line primop should be replaced by an--- inline implementation. This might happen e.g. if there's enough--- static information, such as statically know arguments, to emit a--- more efficient implementation inline.------ Returns 'Nothing' if this primop should use its out-of-line--- implementation (defined elsewhere) and 'Just' together with a code--- generating function that takes the output regs as arguments--- otherwise.-shouldInlinePrimOp :: DynFlags-                   -> PrimOp     -- ^ The primop-                   -> [CmmExpr]  -- ^ The primop arguments-                   -> Maybe ([LocalReg] -> FCode ())--shouldInlinePrimOp dflags NewByteArrayOp_Char [(CmmLit (CmmInt n w))]-  | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags) =-      Just $ \ [res] -> doNewByteArrayOp res (fromInteger n)--shouldInlinePrimOp dflags NewArrayOp [(CmmLit (CmmInt n w)), init]-  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =-      Just $ \ [res] ->-      doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel-      [ (mkIntExpr dflags (fromInteger n),-         fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags)-      , (mkIntExpr dflags (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))),-         fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags)-      ]-      (fromInteger n) init--shouldInlinePrimOp _ CopyArrayOp-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =-        Just $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)--shouldInlinePrimOp _ CopyMutableArrayOp-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =-        Just $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)--shouldInlinePrimOp _ CopyArrayArrayOp-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =-        Just $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)--shouldInlinePrimOp _ CopyMutableArrayArrayOp-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =-        Just $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)--shouldInlinePrimOp dflags CloneArrayOp [src, src_off, (CmmLit (CmmInt n w))]-  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =-      Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)--shouldInlinePrimOp dflags CloneMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))]-  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =-      Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)--shouldInlinePrimOp dflags FreezeArrayOp [src, src_off, (CmmLit (CmmInt n w))]-  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =-      Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)--shouldInlinePrimOp dflags ThawArrayOp [src, src_off, (CmmLit (CmmInt n w))]-  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =-      Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)--shouldInlinePrimOp dflags NewSmallArrayOp [(CmmLit (CmmInt n w)), init]-  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =-      Just $ \ [res] ->-      doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel-      [ (mkIntExpr dflags (fromInteger n),-         fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags)-      ]-      (fromInteger n) init--shouldInlinePrimOp _ CopySmallArrayOp-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =-        Just $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n)--shouldInlinePrimOp _ CopySmallMutableArrayOp-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =-        Just $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n)--shouldInlinePrimOp dflags CloneSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]-  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =-      Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)--shouldInlinePrimOp dflags CloneSmallMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))]-  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =-      Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)--shouldInlinePrimOp dflags FreezeSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]-  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =-      Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)--shouldInlinePrimOp dflags ThawSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]-  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =-      Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)--shouldInlinePrimOp dflags primop args-  | primOpOutOfLine primop = Nothing-  | otherwise = Just $ \ regs -> emitPrimOp dflags regs primop args---- TODO: Several primops, such as 'copyArray#', only have an inline--- implementation (below) but could possibly have both an inline--- implementation and an out-of-line implementation, just like--- 'newArray#'. This would lower the amount of code generated,--- hopefully without a performance impact (needs to be measured).------------------------------------------------------cgPrimOp   :: [LocalReg]        -- where to put the results-           -> PrimOp            -- the op-           -> [StgArg]          -- arguments-           -> FCode ()--cgPrimOp results op args-  = do dflags <- getDynFlags-       arg_exprs <- getNonVoidArgAmodes args-       emitPrimOp dflags results op arg_exprs------------------------------------------------------------------------------      Emitting code for a primop---------------------------------------------------------------------------emitPrimOp :: DynFlags-           -> [LocalReg]        -- where to put the results-           -> PrimOp            -- the op-           -> [CmmExpr]         -- arguments-           -> FCode ()---- First we handle various awkward cases specially.  The remaining--- easy cases are then handled by translateOp, defined below.--emitPrimOp _ [res] ParOp [arg]-  =-        -- for now, just implement this in a C function-        -- later, we might want to inline it.-    emitCCall-        [(res,NoHint)]-        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))-        [(baseExpr, AddrHint), (arg,AddrHint)]--emitPrimOp dflags [res] SparkOp [arg]-  = do-        -- returns the value of arg in res.  We're going to therefore-        -- refer to arg twice (once to pass to newSpark(), and once to-        -- assign to res), so put it in a temporary.-        tmp <- assignTemp arg-        tmp2 <- newTemp (bWord dflags)-        emitCCall-            [(tmp2,NoHint)]-            (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))-            [(baseExpr, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]-        emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))--emitPrimOp dflags [res] GetCCSOfOp [arg]-  = emitAssign (CmmLocal res) val-  where-    val-     | gopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg)-     | otherwise                      = CmmLit (zeroCLit dflags)--emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg]-   = emitAssign (CmmLocal res) cccsExpr--emitPrimOp _ [res] MyThreadIdOp []-   = emitAssign (CmmLocal res) currentTSOExpr--emitPrimOp dflags [res] ReadMutVarOp [mutv]-   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))--emitPrimOp dflags res@[] WriteMutVarOp [mutv,var]-   = do -- Without this write barrier, other CPUs may see this pointer before-        -- the writes for the closure it points to have occurred.-        emitPrimCall res MO_WriteBarrier []-        emitStore (cmmOffsetW dflags mutv (fixedHdrSizeW dflags)) var-        emitCCall-                [{-no results-}]-                (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))-                [(baseExpr, AddrHint), (mutv,AddrHint)]----  #define sizzeofByteArrayzh(r,a) \---     r = ((StgArrBytes *)(a))->bytes-emitPrimOp dflags [res] SizeofByteArrayOp [arg]-   = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))----  #define sizzeofMutableByteArrayzh(r,a) \---      r = ((StgArrBytes *)(a))->bytes-emitPrimOp dflags [res] SizeofMutableByteArrayOp [arg]-   = emitPrimOp dflags [res] SizeofByteArrayOp [arg]----  #define getSizzeofMutableByteArrayzh(r,a) \---      r = ((StgArrBytes *)(a))->bytes-emitPrimOp dflags [res] GetSizeofMutableByteArrayOp [arg]-   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))-----  #define touchzh(o)                  /* nothing */-emitPrimOp _ res@[] TouchOp args@[_arg]-   = do emitPrimCall res MO_Touch args----  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)-emitPrimOp dflags [res] ByteArrayContents_Char [arg]-   = emitAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags))----  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)-emitPrimOp dflags [res] StableNameToIntOp [arg]-   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))--emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2]-   = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])----  #define addrToHValuezh(r,a) r=(P_)a-emitPrimOp _      [res] AddrToAnyOp [arg]-   = emitAssign (CmmLocal res) arg----  #define hvalueToAddrzh(r, a) r=(W_)a-emitPrimOp _      [res] AnyToAddrOp [arg]-   = emitAssign (CmmLocal res) arg--{- Freezing arrays-of-ptrs requires changing an info table, for the-   benefit of the generational collector.  It needs to scavenge mutable-   objects, even if they are in old space.  When they become immutable,-   they can be removed from this scavenge list.  -}----  #define unsafeFreezzeArrayzh(r,a)---      {---        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info);---        r = a;---      }-emitPrimOp _      [res] UnsafeFreezeArrayOp [arg]-   = emit $ catAGraphs-   [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),-     mkAssign (CmmLocal res) arg ]-emitPrimOp _      [res] UnsafeFreezeArrayArrayOp [arg]-   = emit $ catAGraphs-   [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),-     mkAssign (CmmLocal res) arg ]-emitPrimOp _      [res] UnsafeFreezeSmallArrayOp [arg]-   = emit $ catAGraphs-   [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)),-     mkAssign (CmmLocal res) arg ]----  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)-emitPrimOp _      [res] UnsafeFreezeByteArrayOp [arg]-   = emitAssign (CmmLocal res) arg---- Reading/writing pointer arrays--emitPrimOp _      [res] ReadArrayOp  [obj,ix]    = doReadPtrArrayOp res obj ix-emitPrimOp _      [res] IndexArrayOp [obj,ix]    = doReadPtrArrayOp res obj ix-emitPrimOp _      []  WriteArrayOp [obj,ix,v]  = doWritePtrArrayOp obj ix v--emitPrimOp _      [res] IndexArrayArrayOp_ByteArray         [obj,ix]   = doReadPtrArrayOp res obj ix-emitPrimOp _      [res] IndexArrayArrayOp_ArrayArray        [obj,ix]   = doReadPtrArrayOp res obj ix-emitPrimOp _      [res] ReadArrayArrayOp_ByteArray          [obj,ix]   = doReadPtrArrayOp res obj ix-emitPrimOp _      [res] ReadArrayArrayOp_MutableByteArray   [obj,ix]   = doReadPtrArrayOp res obj ix-emitPrimOp _      [res] ReadArrayArrayOp_ArrayArray         [obj,ix]   = doReadPtrArrayOp res obj ix-emitPrimOp _      [res] ReadArrayArrayOp_MutableArrayArray  [obj,ix]   = doReadPtrArrayOp res obj ix-emitPrimOp _      []  WriteArrayArrayOp_ByteArray         [obj,ix,v] = doWritePtrArrayOp obj ix v-emitPrimOp _      []  WriteArrayArrayOp_MutableByteArray  [obj,ix,v] = doWritePtrArrayOp obj ix v-emitPrimOp _      []  WriteArrayArrayOp_ArrayArray        [obj,ix,v] = doWritePtrArrayOp obj ix v-emitPrimOp _      []  WriteArrayArrayOp_MutableArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v--emitPrimOp _      [res] ReadSmallArrayOp  [obj,ix] = doReadSmallPtrArrayOp res obj ix-emitPrimOp _      [res] IndexSmallArrayOp [obj,ix] = doReadSmallPtrArrayOp res obj ix-emitPrimOp _      []  WriteSmallArrayOp [obj,ix,v] = doWriteSmallPtrArrayOp obj ix v---- Getting the size of pointer arrays--emitPrimOp dflags [res] SizeofArrayOp [arg]-   = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg-    (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgMutArrPtrs_ptrs dflags))-        (bWord dflags))-emitPrimOp dflags [res] SizeofMutableArrayOp [arg]-   = emitPrimOp dflags [res] SizeofArrayOp [arg]-emitPrimOp dflags [res] SizeofArrayArrayOp [arg]-   = emitPrimOp dflags [res] SizeofArrayOp [arg]-emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg]-   = emitPrimOp dflags [res] SizeofArrayOp [arg]--emitPrimOp dflags [res] SizeofSmallArrayOp [arg] =-    emit $ mkAssign (CmmLocal res)-    (cmmLoadIndexW dflags arg-     (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgSmallMutArrPtrs_ptrs dflags))-        (bWord dflags))-emitPrimOp dflags [res] SizeofSmallMutableArrayOp [arg] =-    emitPrimOp dflags [res] SizeofSmallArrayOp [arg]---- IndexXXXoffAddr--emitPrimOp dflags res IndexOffAddrOp_Char             args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args-emitPrimOp dflags res IndexOffAddrOp_WideChar         args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args-emitPrimOp dflags res IndexOffAddrOp_Int              args = doIndexOffAddrOp   Nothing (bWord dflags) res args-emitPrimOp dflags res IndexOffAddrOp_Word             args = doIndexOffAddrOp   Nothing (bWord dflags) res args-emitPrimOp dflags res IndexOffAddrOp_Addr             args = doIndexOffAddrOp   Nothing (bWord dflags) res args-emitPrimOp _      res IndexOffAddrOp_Float            args = doIndexOffAddrOp   Nothing f32 res args-emitPrimOp _      res IndexOffAddrOp_Double           args = doIndexOffAddrOp   Nothing f64 res args-emitPrimOp dflags res IndexOffAddrOp_StablePtr        args = doIndexOffAddrOp   Nothing (bWord dflags) res args-emitPrimOp dflags res IndexOffAddrOp_Int8             args = doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args-emitPrimOp dflags res IndexOffAddrOp_Int16            args = doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args-emitPrimOp dflags res IndexOffAddrOp_Int32            args = doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args-emitPrimOp _      res IndexOffAddrOp_Int64            args = doIndexOffAddrOp   Nothing b64 res args-emitPrimOp dflags res IndexOffAddrOp_Word8            args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args-emitPrimOp dflags res IndexOffAddrOp_Word16           args = doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args-emitPrimOp dflags res IndexOffAddrOp_Word32           args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args-emitPrimOp _      res IndexOffAddrOp_Word64           args = doIndexOffAddrOp   Nothing b64 res args---- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.--emitPrimOp dflags res ReadOffAddrOp_Char             args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args-emitPrimOp dflags res ReadOffAddrOp_WideChar         args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args-emitPrimOp dflags res ReadOffAddrOp_Int              args = doIndexOffAddrOp   Nothing (bWord dflags) res args-emitPrimOp dflags res ReadOffAddrOp_Word             args = doIndexOffAddrOp   Nothing (bWord dflags) res args-emitPrimOp dflags res ReadOffAddrOp_Addr             args = doIndexOffAddrOp   Nothing (bWord dflags) res args-emitPrimOp _      res ReadOffAddrOp_Float            args = doIndexOffAddrOp   Nothing f32 res args-emitPrimOp _      res ReadOffAddrOp_Double           args = doIndexOffAddrOp   Nothing f64 res args-emitPrimOp dflags res ReadOffAddrOp_StablePtr        args = doIndexOffAddrOp   Nothing (bWord dflags) res args-emitPrimOp dflags res ReadOffAddrOp_Int8             args = doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args-emitPrimOp dflags res ReadOffAddrOp_Int16            args = doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args-emitPrimOp dflags res ReadOffAddrOp_Int32            args = doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args-emitPrimOp _      res ReadOffAddrOp_Int64            args = doIndexOffAddrOp   Nothing b64 res args-emitPrimOp dflags res ReadOffAddrOp_Word8            args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args-emitPrimOp dflags res ReadOffAddrOp_Word16           args = doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args-emitPrimOp dflags res ReadOffAddrOp_Word32           args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args-emitPrimOp _      res ReadOffAddrOp_Word64           args = doIndexOffAddrOp   Nothing b64 res args---- IndexXXXArray--emitPrimOp dflags res IndexByteArrayOp_Char             args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args-emitPrimOp dflags res IndexByteArrayOp_WideChar         args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args-emitPrimOp dflags res IndexByteArrayOp_Int              args = doIndexByteArrayOp   Nothing (bWord dflags) res args-emitPrimOp dflags res IndexByteArrayOp_Word             args = doIndexByteArrayOp   Nothing (bWord dflags) res args-emitPrimOp dflags res IndexByteArrayOp_Addr             args = doIndexByteArrayOp   Nothing (bWord dflags) res args-emitPrimOp _      res IndexByteArrayOp_Float            args = doIndexByteArrayOp   Nothing f32 res args-emitPrimOp _      res IndexByteArrayOp_Double           args = doIndexByteArrayOp   Nothing f64 res args-emitPrimOp dflags res IndexByteArrayOp_StablePtr        args = doIndexByteArrayOp   Nothing (bWord dflags) res args-emitPrimOp dflags res IndexByteArrayOp_Int8             args = doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args-emitPrimOp dflags res IndexByteArrayOp_Int16            args = doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args-emitPrimOp dflags res IndexByteArrayOp_Int32            args = doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args-emitPrimOp _      res IndexByteArrayOp_Int64            args = doIndexByteArrayOp   Nothing b64  res args-emitPrimOp dflags res IndexByteArrayOp_Word8            args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args-emitPrimOp dflags res IndexByteArrayOp_Word16           args = doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args-emitPrimOp dflags res IndexByteArrayOp_Word32           args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args-emitPrimOp _      res IndexByteArrayOp_Word64           args = doIndexByteArrayOp   Nothing b64  res args---- ReadXXXArray, identical to IndexXXXArray.--emitPrimOp dflags res ReadByteArrayOp_Char             args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args-emitPrimOp dflags res ReadByteArrayOp_WideChar         args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args-emitPrimOp dflags res ReadByteArrayOp_Int              args = doIndexByteArrayOp   Nothing (bWord dflags) res args-emitPrimOp dflags res ReadByteArrayOp_Word             args = doIndexByteArrayOp   Nothing (bWord dflags) res args-emitPrimOp dflags res ReadByteArrayOp_Addr             args = doIndexByteArrayOp   Nothing (bWord dflags) res args-emitPrimOp _      res ReadByteArrayOp_Float            args = doIndexByteArrayOp   Nothing f32 res args-emitPrimOp _      res ReadByteArrayOp_Double           args = doIndexByteArrayOp   Nothing f64 res args-emitPrimOp dflags res ReadByteArrayOp_StablePtr        args = doIndexByteArrayOp   Nothing (bWord dflags) res args-emitPrimOp dflags res ReadByteArrayOp_Int8             args = doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args-emitPrimOp dflags res ReadByteArrayOp_Int16            args = doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args-emitPrimOp dflags res ReadByteArrayOp_Int32            args = doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args-emitPrimOp _      res ReadByteArrayOp_Int64            args = doIndexByteArrayOp   Nothing b64  res args-emitPrimOp dflags res ReadByteArrayOp_Word8            args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args-emitPrimOp dflags res ReadByteArrayOp_Word16           args = doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args-emitPrimOp dflags res ReadByteArrayOp_Word32           args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args-emitPrimOp _      res ReadByteArrayOp_Word64           args = doIndexByteArrayOp   Nothing b64  res args---- IndexWord8ArrayAsXXX--emitPrimOp dflags res IndexByteArrayOp_Word8AsChar      args = doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args-emitPrimOp dflags res IndexByteArrayOp_Word8AsWideChar  args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args-emitPrimOp dflags res IndexByteArrayOp_Word8AsInt       args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-emitPrimOp dflags res IndexByteArrayOp_Word8AsWord      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-emitPrimOp dflags res IndexByteArrayOp_Word8AsAddr      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-emitPrimOp _      res IndexByteArrayOp_Word8AsFloat     args = doIndexByteArrayOpAs   Nothing f32 b8 res args-emitPrimOp _      res IndexByteArrayOp_Word8AsDouble    args = doIndexByteArrayOpAs   Nothing f64 b8 res args-emitPrimOp dflags res IndexByteArrayOp_Word8AsStablePtr args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-emitPrimOp dflags res IndexByteArrayOp_Word8AsInt16     args = doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args-emitPrimOp dflags res IndexByteArrayOp_Word8AsInt32     args = doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args-emitPrimOp _      res IndexByteArrayOp_Word8AsInt64     args = doIndexByteArrayOpAs   Nothing b64 b8 res args-emitPrimOp dflags res IndexByteArrayOp_Word8AsWord16    args = doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args-emitPrimOp dflags res IndexByteArrayOp_Word8AsWord32    args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args-emitPrimOp _      res IndexByteArrayOp_Word8AsWord64    args = doIndexByteArrayOpAs   Nothing b64 b8 res args---- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX--emitPrimOp dflags res ReadByteArrayOp_Word8AsChar      args = doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args-emitPrimOp dflags res ReadByteArrayOp_Word8AsWideChar  args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args-emitPrimOp dflags res ReadByteArrayOp_Word8AsInt       args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-emitPrimOp dflags res ReadByteArrayOp_Word8AsWord      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-emitPrimOp dflags res ReadByteArrayOp_Word8AsAddr      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-emitPrimOp _      res ReadByteArrayOp_Word8AsFloat     args = doIndexByteArrayOpAs   Nothing f32 b8 res args-emitPrimOp _      res ReadByteArrayOp_Word8AsDouble    args = doIndexByteArrayOpAs   Nothing f64 b8 res args-emitPrimOp dflags res ReadByteArrayOp_Word8AsStablePtr args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-emitPrimOp dflags res ReadByteArrayOp_Word8AsInt16     args = doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args-emitPrimOp dflags res ReadByteArrayOp_Word8AsInt32     args = doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args-emitPrimOp _      res ReadByteArrayOp_Word8AsInt64     args = doIndexByteArrayOpAs   Nothing b64 b8 res args-emitPrimOp dflags res ReadByteArrayOp_Word8AsWord16    args = doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args-emitPrimOp dflags res ReadByteArrayOp_Word8AsWord32    args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args-emitPrimOp _      res ReadByteArrayOp_Word8AsWord64    args = doIndexByteArrayOpAs   Nothing b64 b8 res args---- WriteXXXoffAddr--emitPrimOp dflags res WriteOffAddrOp_Char             args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args-emitPrimOp dflags res WriteOffAddrOp_WideChar         args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args-emitPrimOp dflags res WriteOffAddrOp_Int              args = doWriteOffAddrOp Nothing (bWord dflags) res args-emitPrimOp dflags res WriteOffAddrOp_Word             args = doWriteOffAddrOp Nothing (bWord dflags) res args-emitPrimOp dflags res WriteOffAddrOp_Addr             args = doWriteOffAddrOp Nothing (bWord dflags) res args-emitPrimOp _      res WriteOffAddrOp_Float            args = doWriteOffAddrOp Nothing f32 res args-emitPrimOp _      res WriteOffAddrOp_Double           args = doWriteOffAddrOp Nothing f64 res args-emitPrimOp dflags res WriteOffAddrOp_StablePtr        args = doWriteOffAddrOp Nothing (bWord dflags) res args-emitPrimOp dflags res WriteOffAddrOp_Int8             args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args-emitPrimOp dflags res WriteOffAddrOp_Int16            args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args-emitPrimOp dflags res WriteOffAddrOp_Int32            args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args-emitPrimOp _      res WriteOffAddrOp_Int64            args = doWriteOffAddrOp Nothing b64 res args-emitPrimOp dflags res WriteOffAddrOp_Word8            args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args-emitPrimOp dflags res WriteOffAddrOp_Word16           args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args-emitPrimOp dflags res WriteOffAddrOp_Word32           args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args-emitPrimOp _      res WriteOffAddrOp_Word64           args = doWriteOffAddrOp Nothing b64 res args---- WriteXXXArray--emitPrimOp dflags res WriteByteArrayOp_Char             args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args-emitPrimOp dflags res WriteByteArrayOp_WideChar         args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args-emitPrimOp dflags res WriteByteArrayOp_Int              args = doWriteByteArrayOp Nothing (bWord dflags) res args-emitPrimOp dflags res WriteByteArrayOp_Word             args = doWriteByteArrayOp Nothing (bWord dflags) res args-emitPrimOp dflags res WriteByteArrayOp_Addr             args = doWriteByteArrayOp Nothing (bWord dflags) res args-emitPrimOp _      res WriteByteArrayOp_Float            args = doWriteByteArrayOp Nothing f32 res args-emitPrimOp _      res WriteByteArrayOp_Double           args = doWriteByteArrayOp Nothing f64 res args-emitPrimOp dflags res WriteByteArrayOp_StablePtr        args = doWriteByteArrayOp Nothing (bWord dflags) res args-emitPrimOp dflags res WriteByteArrayOp_Int8             args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args-emitPrimOp dflags res WriteByteArrayOp_Int16            args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args-emitPrimOp dflags res WriteByteArrayOp_Int32            args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args-emitPrimOp _      res WriteByteArrayOp_Int64            args = doWriteByteArrayOp Nothing b64 res args-emitPrimOp dflags res WriteByteArrayOp_Word8            args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8  res args-emitPrimOp dflags res WriteByteArrayOp_Word16           args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args-emitPrimOp dflags res WriteByteArrayOp_Word32           args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args-emitPrimOp _      res WriteByteArrayOp_Word64           args = doWriteByteArrayOp Nothing b64 res args---- WriteInt8ArrayAsXXX--emitPrimOp dflags res WriteByteArrayOp_Word8AsChar       args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args-emitPrimOp dflags res WriteByteArrayOp_Word8AsWideChar   args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args-emitPrimOp _      res WriteByteArrayOp_Word8AsInt        args = doWriteByteArrayOp Nothing b8 res args-emitPrimOp _      res WriteByteArrayOp_Word8AsWord       args = doWriteByteArrayOp Nothing b8 res args-emitPrimOp _      res WriteByteArrayOp_Word8AsAddr       args = doWriteByteArrayOp Nothing b8 res args-emitPrimOp _      res WriteByteArrayOp_Word8AsFloat      args = doWriteByteArrayOp Nothing b8 res args-emitPrimOp _      res WriteByteArrayOp_Word8AsDouble     args = doWriteByteArrayOp Nothing b8 res args-emitPrimOp _      res WriteByteArrayOp_Word8AsStablePtr  args = doWriteByteArrayOp Nothing b8 res args-emitPrimOp dflags res WriteByteArrayOp_Word8AsInt16      args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args-emitPrimOp dflags res WriteByteArrayOp_Word8AsInt32      args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args-emitPrimOp _      res WriteByteArrayOp_Word8AsInt64      args = doWriteByteArrayOp Nothing b8 res args-emitPrimOp dflags res WriteByteArrayOp_Word8AsWord16     args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args-emitPrimOp dflags res WriteByteArrayOp_Word8AsWord32     args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args-emitPrimOp _      res WriteByteArrayOp_Word8AsWord64     args = doWriteByteArrayOp Nothing b8 res args---- Copying and setting byte arrays-emitPrimOp _      [] CopyByteArrayOp [src,src_off,dst,dst_off,n] =-    doCopyByteArrayOp src src_off dst dst_off n-emitPrimOp _      [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] =-    doCopyMutableByteArrayOp src src_off dst dst_off n-emitPrimOp _      [] CopyByteArrayToAddrOp [src,src_off,dst,n] =-    doCopyByteArrayToAddrOp src src_off dst n-emitPrimOp _      [] CopyMutableByteArrayToAddrOp [src,src_off,dst,n] =-    doCopyMutableByteArrayToAddrOp src src_off dst n-emitPrimOp _      [] CopyAddrToByteArrayOp [src,dst,dst_off,n] =-    doCopyAddrToByteArrayOp src dst dst_off n-emitPrimOp _      [] SetByteArrayOp [ba,off,len,c] =-    doSetByteArrayOp ba off len c---- Comparing byte arrays-emitPrimOp _      [res] CompareByteArraysOp [ba1,ba1_off,ba2,ba2_off,n] =-    doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n--emitPrimOp _      [res] BSwap16Op [w] = emitBSwapCall res w W16-emitPrimOp _      [res] BSwap32Op [w] = emitBSwapCall res w W32-emitPrimOp _      [res] BSwap64Op [w] = emitBSwapCall res w W64-emitPrimOp dflags [res] BSwapOp   [w] = emitBSwapCall res w (wordWidth dflags)---- Population count-emitPrimOp _      [res] PopCnt8Op  [w] = emitPopCntCall res w W8-emitPrimOp _      [res] PopCnt16Op [w] = emitPopCntCall res w W16-emitPrimOp _      [res] PopCnt32Op [w] = emitPopCntCall res w W32-emitPrimOp _      [res] PopCnt64Op [w] = emitPopCntCall res w W64-emitPrimOp dflags [res] PopCntOp   [w] = emitPopCntCall res w (wordWidth dflags)---- Parallel bit deposit-emitPrimOp _      [res] Pdep8Op  [src, mask] = emitPdepCall res src mask W8-emitPrimOp _      [res] Pdep16Op [src, mask] = emitPdepCall res src mask W16-emitPrimOp _      [res] Pdep32Op [src, mask] = emitPdepCall res src mask W32-emitPrimOp _      [res] Pdep64Op [src, mask] = emitPdepCall res src mask W64-emitPrimOp dflags [res] PdepOp   [src, mask] = emitPdepCall res src mask (wordWidth dflags)---- Parallel bit extract-emitPrimOp _      [res] Pext8Op  [src, mask] = emitPextCall res src mask W8-emitPrimOp _      [res] Pext16Op [src, mask] = emitPextCall res src mask W16-emitPrimOp _      [res] Pext32Op [src, mask] = emitPextCall res src mask W32-emitPrimOp _      [res] Pext64Op [src, mask] = emitPextCall res src mask W64-emitPrimOp dflags [res] PextOp   [src, mask] = emitPextCall res src mask (wordWidth dflags)---- count leading zeros-emitPrimOp _      [res] Clz8Op  [w] = emitClzCall res w W8-emitPrimOp _      [res] Clz16Op [w] = emitClzCall res w W16-emitPrimOp _      [res] Clz32Op [w] = emitClzCall res w W32-emitPrimOp _      [res] Clz64Op [w] = emitClzCall res w W64-emitPrimOp dflags [res] ClzOp   [w] = emitClzCall res w (wordWidth dflags)---- count trailing zeros-emitPrimOp _      [res] Ctz8Op [w]  = emitCtzCall res w W8-emitPrimOp _      [res] Ctz16Op [w] = emitCtzCall res w W16-emitPrimOp _      [res] Ctz32Op [w] = emitCtzCall res w W32-emitPrimOp _      [res] Ctz64Op [w] = emitCtzCall res w W64-emitPrimOp dflags [res] CtzOp   [w] = emitCtzCall res w (wordWidth dflags)---- Unsigned int to floating point conversions-emitPrimOp _      [res] Word2FloatOp  [w] = emitPrimCall [res]-                                            (MO_UF_Conv W32) [w]-emitPrimOp _      [res] Word2DoubleOp [w] = emitPrimCall [res]-                                            (MO_UF_Conv W64) [w]---- SIMD primops-emitPrimOp dflags [res] (VecBroadcastOp vcat n w) [e] = do-    checkVecCompatibility dflags vcat n w-    doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros (replicate n e) res-  where-    zeros :: CmmExpr-    zeros = CmmLit $ CmmVec (replicate n zero)--    zero :: CmmLit-    zero = case vcat of-             IntVec   -> CmmInt 0 w-             WordVec  -> CmmInt 0 w-             FloatVec -> CmmFloat 0 w--    ty :: CmmType-    ty = vecVmmType vcat n w--emitPrimOp dflags [res] (VecPackOp vcat n w) es = do-    checkVecCompatibility dflags vcat n w-    when (es `lengthIsNot` n) $-        panic "emitPrimOp: VecPackOp has wrong number of arguments"-    doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros es res-  where-    zeros :: CmmExpr-    zeros = CmmLit $ CmmVec (replicate n zero)--    zero :: CmmLit-    zero = case vcat of-             IntVec   -> CmmInt 0 w-             WordVec  -> CmmInt 0 w-             FloatVec -> CmmFloat 0 w--    ty :: CmmType-    ty = vecVmmType vcat n w--emitPrimOp dflags res (VecUnpackOp vcat n w) [arg] = do-    checkVecCompatibility dflags vcat n w-    when (res `lengthIsNot` n) $-        panic "emitPrimOp: VecUnpackOp has wrong number of results"-    doVecUnpackOp (vecElemProjectCast dflags vcat w) ty arg res-  where-    ty :: CmmType-    ty = vecVmmType vcat n w--emitPrimOp dflags [res] (VecInsertOp vcat n w) [v,e,i] = do-    checkVecCompatibility dflags vcat n w-    doVecInsertOp (vecElemInjectCast dflags vcat w) ty v e i res-  where-    ty :: CmmType-    ty = vecVmmType vcat n w--emitPrimOp dflags res (VecIndexByteArrayOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doIndexByteArrayOp Nothing ty res args-  where-    ty :: CmmType-    ty = vecVmmType vcat n w--emitPrimOp dflags res (VecReadByteArrayOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doIndexByteArrayOp Nothing ty res args-  where-    ty :: CmmType-    ty = vecVmmType vcat n w--emitPrimOp dflags res (VecWriteByteArrayOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doWriteByteArrayOp Nothing ty res args-  where-    ty :: CmmType-    ty = vecVmmType vcat n w--emitPrimOp dflags res (VecIndexOffAddrOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doIndexOffAddrOp Nothing ty res args-  where-    ty :: CmmType-    ty = vecVmmType vcat n w--emitPrimOp dflags res (VecReadOffAddrOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doIndexOffAddrOp Nothing ty res args-  where-    ty :: CmmType-    ty = vecVmmType vcat n w--emitPrimOp dflags res (VecWriteOffAddrOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doWriteOffAddrOp Nothing ty res args-  where-    ty :: CmmType-    ty = vecVmmType vcat n w--emitPrimOp dflags res (VecIndexScalarByteArrayOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doIndexByteArrayOpAs Nothing vecty ty res args-  where-    vecty :: CmmType-    vecty = vecVmmType vcat n w--    ty :: CmmType-    ty = vecCmmCat vcat w--emitPrimOp dflags res (VecReadScalarByteArrayOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doIndexByteArrayOpAs Nothing vecty ty res args-  where-    vecty :: CmmType-    vecty = vecVmmType vcat n w--    ty :: CmmType-    ty = vecCmmCat vcat w--emitPrimOp dflags res (VecWriteScalarByteArrayOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doWriteByteArrayOp Nothing ty res args-  where-    ty :: CmmType-    ty = vecCmmCat vcat w--emitPrimOp dflags res (VecIndexScalarOffAddrOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doIndexOffAddrOpAs Nothing vecty ty res args-  where-    vecty :: CmmType-    vecty = vecVmmType vcat n w--    ty :: CmmType-    ty = vecCmmCat vcat w--emitPrimOp dflags res (VecReadScalarOffAddrOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doIndexOffAddrOpAs Nothing vecty ty res args-  where-    vecty :: CmmType-    vecty = vecVmmType vcat n w--    ty :: CmmType-    ty = vecCmmCat vcat w--emitPrimOp dflags res (VecWriteScalarOffAddrOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doWriteOffAddrOp Nothing ty res args-  where-    ty :: CmmType-    ty = vecCmmCat vcat w---- Prefetch-emitPrimOp _ [] PrefetchByteArrayOp3        args = doPrefetchByteArrayOp 3  args-emitPrimOp _ [] PrefetchMutableByteArrayOp3 args = doPrefetchMutableByteArrayOp 3  args-emitPrimOp _ [] PrefetchAddrOp3             args = doPrefetchAddrOp  3  args-emitPrimOp _ [] PrefetchValueOp3            args = doPrefetchValueOp 3 args--emitPrimOp _ [] PrefetchByteArrayOp2        args = doPrefetchByteArrayOp 2  args-emitPrimOp _ [] PrefetchMutableByteArrayOp2 args = doPrefetchMutableByteArrayOp 2  args-emitPrimOp _ [] PrefetchAddrOp2             args = doPrefetchAddrOp 2  args-emitPrimOp _ [] PrefetchValueOp2           args = doPrefetchValueOp 2 args--emitPrimOp _ [] PrefetchByteArrayOp1        args = doPrefetchByteArrayOp 1  args-emitPrimOp _ [] PrefetchMutableByteArrayOp1 args = doPrefetchMutableByteArrayOp 1  args-emitPrimOp _ [] PrefetchAddrOp1             args = doPrefetchAddrOp 1  args-emitPrimOp _ [] PrefetchValueOp1            args = doPrefetchValueOp 1 args--emitPrimOp _ [] PrefetchByteArrayOp0        args = doPrefetchByteArrayOp 0  args-emitPrimOp _ [] PrefetchMutableByteArrayOp0 args = doPrefetchMutableByteArrayOp 0  args-emitPrimOp _ [] PrefetchAddrOp0             args = doPrefetchAddrOp 0  args-emitPrimOp _ [] PrefetchValueOp0            args = doPrefetchValueOp 0 args---- Atomic read-modify-write-emitPrimOp dflags [res] FetchAddByteArrayOp_Int [mba, ix, n] =-    doAtomicRMW res AMO_Add mba ix (bWord dflags) n-emitPrimOp dflags [res] FetchSubByteArrayOp_Int [mba, ix, n] =-    doAtomicRMW res AMO_Sub mba ix (bWord dflags) n-emitPrimOp dflags [res] FetchAndByteArrayOp_Int [mba, ix, n] =-    doAtomicRMW res AMO_And mba ix (bWord dflags) n-emitPrimOp dflags [res] FetchNandByteArrayOp_Int [mba, ix, n] =-    doAtomicRMW res AMO_Nand mba ix (bWord dflags) n-emitPrimOp dflags [res] FetchOrByteArrayOp_Int [mba, ix, n] =-    doAtomicRMW res AMO_Or mba ix (bWord dflags) n-emitPrimOp dflags [res] FetchXorByteArrayOp_Int [mba, ix, n] =-    doAtomicRMW res AMO_Xor mba ix (bWord dflags) n-emitPrimOp dflags [res] AtomicReadByteArrayOp_Int [mba, ix] =-    doAtomicReadByteArray res mba ix (bWord dflags)-emitPrimOp dflags [] AtomicWriteByteArrayOp_Int [mba, ix, val] =-    doAtomicWriteByteArray mba ix (bWord dflags) val-emitPrimOp dflags [res] CasByteArrayOp_Int [mba, ix, old, new] =-    doCasByteArray res mba ix (bWord dflags) old new---- The rest just translate straightforwardly-emitPrimOp dflags [res] op [arg]-   | nopOp op-   = emitAssign (CmmLocal res) arg--   | Just (mop,rep) <- narrowOp op-   = emitAssign (CmmLocal res) $-           CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]]--emitPrimOp dflags r@[res] op args-   | Just prim <- callishOp op-   = do emitPrimCall r prim args--   | Just mop <- translateOp dflags op-   = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in-     emit stmt--emitPrimOp dflags results op args-   = case callishPrimOpSupported dflags op of-          Left op   -> emit $ mkUnsafeCall (PrimTarget op) results args-          Right gen -> gen results args--type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()--callishPrimOpSupported :: DynFlags -> PrimOp -> Either CallishMachOp GenericOp-callishPrimOpSupported dflags op-  = case op of-      IntQuotRemOp   | ncg && (x86ish || ppc) ->-                         Left (MO_S_QuotRem  (wordWidth dflags))-                     | otherwise              ->-                         Right (genericIntQuotRemOp (wordWidth dflags))--      Int8QuotRemOp  | ncg && (x86ish || ppc)-                                     -> Left (MO_S_QuotRem W8)-                     | otherwise     -> Right (genericIntQuotRemOp W8)--      Int16QuotRemOp | ncg && (x86ish || ppc)-                                     -> Left (MO_S_QuotRem W16)-                     | otherwise     -> Right (genericIntQuotRemOp W16)---      WordQuotRemOp  | ncg && (x86ish || ppc) ->-                         Left (MO_U_QuotRem  (wordWidth dflags))-                     | otherwise      ->-                         Right (genericWordQuotRemOp (wordWidth dflags))--      WordQuotRem2Op | (ncg && (x86ish || ppc))-                          || llvm     -> Left (MO_U_QuotRem2 (wordWidth dflags))-                     | otherwise      -> Right (genericWordQuotRem2Op dflags)--      Word8QuotRemOp | ncg && (x86ish || ppc)-                                      -> Left (MO_U_QuotRem W8)-                     | otherwise      -> Right (genericWordQuotRemOp W8)--      Word16QuotRemOp| ncg && (x86ish || ppc)-                                     -> Left (MO_U_QuotRem W16)-                     | otherwise     -> Right (genericWordQuotRemOp W16)--      WordAdd2Op     | (ncg && (x86ish || ppc))-                         || llvm      -> Left (MO_Add2       (wordWidth dflags))-                     | otherwise      -> Right genericWordAdd2Op--      WordAddCOp     | (ncg && (x86ish || ppc))-                         || llvm      -> Left (MO_AddWordC   (wordWidth dflags))-                     | otherwise      -> Right genericWordAddCOp--      WordSubCOp     | (ncg && (x86ish || ppc))-                         || llvm      -> Left (MO_SubWordC   (wordWidth dflags))-                     | otherwise      -> Right genericWordSubCOp--      IntAddCOp      | (ncg && (x86ish || ppc))-                         || llvm      -> Left (MO_AddIntC    (wordWidth dflags))-                     | otherwise      -> Right genericIntAddCOp--      IntSubCOp      | (ncg && (x86ish || ppc))-                         || llvm      -> Left (MO_SubIntC    (wordWidth dflags))-                     | otherwise      -> Right genericIntSubCOp--      WordMul2Op     | ncg && (x86ish || ppc)-                         || llvm      -> Left (MO_U_Mul2     (wordWidth dflags))-                     | otherwise      -> Right genericWordMul2Op-      FloatFabsOp    | (ncg && x86ish || ppc)-                         || llvm      -> Left MO_F32_Fabs-                     | otherwise      -> Right $ genericFabsOp W32-      DoubleFabsOp   | (ncg && x86ish || ppc)-                         || llvm      -> Left MO_F64_Fabs-                     | otherwise      -> Right $ genericFabsOp W64--      _ -> pprPanic "emitPrimOp: can't translate PrimOp " (ppr op)- where-  ncg = case hscTarget dflags of-           HscAsm -> True-           _      -> False-  llvm = case hscTarget dflags of-           HscLlvm -> True-           _       -> False-  x86ish = case platformArch (targetPlatform dflags) of-             ArchX86    -> True-             ArchX86_64 -> True-             _          -> False-  ppc = case platformArch (targetPlatform dflags) of-          ArchPPC      -> True-          ArchPPC_64 _ -> True-          _            -> False--genericIntQuotRemOp :: Width -> GenericOp-genericIntQuotRemOp width [res_q, res_r] [arg_x, arg_y]-   = emit $ mkAssign (CmmLocal res_q)-              (CmmMachOp (MO_S_Quot width) [arg_x, arg_y]) <*>-            mkAssign (CmmLocal res_r)-              (CmmMachOp (MO_S_Rem  width) [arg_x, arg_y])-genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp"--genericWordQuotRemOp :: Width -> GenericOp-genericWordQuotRemOp width [res_q, res_r] [arg_x, arg_y]-    = emit $ mkAssign (CmmLocal res_q)-               (CmmMachOp (MO_U_Quot width) [arg_x, arg_y]) <*>-             mkAssign (CmmLocal res_r)-               (CmmMachOp (MO_U_Rem  width) [arg_x, arg_y])-genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp"--genericWordQuotRem2Op :: DynFlags -> GenericOp-genericWordQuotRem2Op dflags [res_q, res_r] [arg_x_high, arg_x_low, arg_y]-    = emit =<< f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low-    where    ty = cmmExprType dflags arg_x_high-             shl   x i = CmmMachOp (MO_Shl   (wordWidth dflags)) [x, i]-             shr   x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i]-             or    x y = CmmMachOp (MO_Or    (wordWidth dflags)) [x, y]-             ge    x y = CmmMachOp (MO_U_Ge  (wordWidth dflags)) [x, y]-             ne    x y = CmmMachOp (MO_Ne    (wordWidth dflags)) [x, y]-             minus x y = CmmMachOp (MO_Sub   (wordWidth dflags)) [x, y]-             times x y = CmmMachOp (MO_Mul   (wordWidth dflags)) [x, y]-             zero   = lit 0-             one    = lit 1-             negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1)-             lit i = CmmLit (CmmInt i (wordWidth dflags))--             f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph-             f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*>-                                      mkAssign (CmmLocal res_r) high)-             f i acc high low =-                 do roverflowedBit <- newTemp ty-                    rhigh'         <- newTemp ty-                    rhigh''        <- newTemp ty-                    rlow'          <- newTemp ty-                    risge          <- newTemp ty-                    racc'          <- newTemp ty-                    let high'         = CmmReg (CmmLocal rhigh')-                        isge          = CmmReg (CmmLocal risge)-                        overflowedBit = CmmReg (CmmLocal roverflowedBit)-                    let this = catAGraphs-                               [mkAssign (CmmLocal roverflowedBit)-                                          (shr high negone),-                                mkAssign (CmmLocal rhigh')-                                          (or (shl high one) (shr low negone)),-                                mkAssign (CmmLocal rlow')-                                          (shl low one),-                                mkAssign (CmmLocal risge)-                                          (or (overflowedBit `ne` zero)-                                              (high' `ge` arg_y)),-                                mkAssign (CmmLocal rhigh'')-                                          (high' `minus` (arg_y `times` isge)),-                                mkAssign (CmmLocal racc')-                                          (or (shl acc one) isge)]-                    rest <- f (i - 1) (CmmReg (CmmLocal racc'))-                                      (CmmReg (CmmLocal rhigh''))-                                      (CmmReg (CmmLocal rlow'))-                    return (this <*> rest)-genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op"--genericWordAdd2Op :: GenericOp-genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]-  = do dflags <- getDynFlags-       r1 <- newTemp (cmmExprType dflags arg_x)-       r2 <- newTemp (cmmExprType dflags arg_x)-       let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]-           toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]-           bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]-           add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]-           or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]-           hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))-                                (wordWidth dflags))-           hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))-       emit $ catAGraphs-          [mkAssign (CmmLocal r1)-               (add (bottomHalf arg_x) (bottomHalf arg_y)),-           mkAssign (CmmLocal r2)-               (add (topHalf (CmmReg (CmmLocal r1)))-                    (add (topHalf arg_x) (topHalf arg_y))),-           mkAssign (CmmLocal res_h)-               (topHalf (CmmReg (CmmLocal r2))),-           mkAssign (CmmLocal res_l)-               (or (toTopHalf (CmmReg (CmmLocal r2)))-                   (bottomHalf (CmmReg (CmmLocal r1))))]-genericWordAdd2Op _ _ = panic "genericWordAdd2Op"---- | Implements branchless recovery of the carry flag @c@ by checking the--- leftmost bits of both inputs @a@ and @b@ and result @r = a + b@:------ @---    c = a&b | (a|b)&~r--- @------ https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/-genericWordAddCOp :: GenericOp-genericWordAddCOp [res_r, res_c] [aa, bb]- = do dflags <- getDynFlags-      emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),-        mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr dflags) [-            CmmMachOp (mo_wordOr dflags) [-              CmmMachOp (mo_wordAnd dflags) [aa,bb],-              CmmMachOp (mo_wordAnd dflags) [-                CmmMachOp (mo_wordOr dflags) [aa,bb],-                CmmMachOp (mo_wordNot dflags) [CmmReg (CmmLocal res_r)]-              ]-            ],-            mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)-          ]-        ]-genericWordAddCOp _ _ = panic "genericWordAddCOp"---- | Implements branchless recovery of the carry flag @c@ by checking the--- leftmost bits of both inputs @a@ and @b@ and result @r = a - b@:------ @---    c = ~a&b | (~a|b)&r--- @------ https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/-genericWordSubCOp :: GenericOp-genericWordSubCOp [res_r, res_c] [aa, bb]- = do dflags <- getDynFlags-      emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),-        mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr dflags) [-            CmmMachOp (mo_wordOr dflags) [-              CmmMachOp (mo_wordAnd dflags) [-                CmmMachOp (mo_wordNot dflags) [aa],-                bb-              ],-              CmmMachOp (mo_wordAnd dflags) [-                CmmMachOp (mo_wordOr dflags) [-                  CmmMachOp (mo_wordNot dflags) [aa],-                  bb-                ],-                CmmReg (CmmLocal res_r)-              ]-            ],-            mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)-          ]-        ]-genericWordSubCOp _ _ = panic "genericWordSubCOp"--genericIntAddCOp :: GenericOp-genericIntAddCOp [res_r, res_c] [aa, bb]-{--   With some bit-twiddling, we can define int{Add,Sub}Czh portably in-   C, and without needing any comparisons.  This may not be the-   fastest way to do it - if you have better code, please send it! --SDM--   Return : r = a + b,  c = 0 if no overflow, 1 on overflow.--   We currently don't make use of the r value if c is != 0 (i.e.-   overflow), we just convert to big integers and try again.  This-   could be improved by making r and c the correct values for-   plugging into a new J#.--   { r = ((I_)(a)) + ((I_)(b));                                 \-     c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \-         >> (BITS_IN (I_) - 1);                                 \-   }-   Wading through the mass of bracketry, it seems to reduce to:-   c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)---}- = do dflags <- getDynFlags-      emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),-        mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr dflags) [-                CmmMachOp (mo_wordAnd dflags) [-                    CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]],-                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]-                ],-                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)-          ]-        ]-genericIntAddCOp _ _ = panic "genericIntAddCOp"--genericIntSubCOp :: GenericOp-genericIntSubCOp [res_r, res_c] [aa, bb]-{- Similarly:-   #define subIntCzh(r,c,a,b)                                   \-   { r = ((I_)(a)) - ((I_)(b));                                 \-     c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \-         >> (BITS_IN (I_) - 1);                                 \-   }--   c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)--}- = do dflags <- getDynFlags-      emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),-        mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr dflags) [-                CmmMachOp (mo_wordAnd dflags) [-                    CmmMachOp (mo_wordXor dflags) [aa,bb],-                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]-                ],-                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)-          ]-        ]-genericIntSubCOp _ _ = panic "genericIntSubCOp"--genericWordMul2Op :: GenericOp-genericWordMul2Op [res_h, res_l] [arg_x, arg_y]- = do dflags <- getDynFlags-      let t = cmmExprType dflags arg_x-      xlyl <- liftM CmmLocal $ newTemp t-      xlyh <- liftM CmmLocal $ newTemp t-      xhyl <- liftM CmmLocal $ newTemp t-      r    <- liftM CmmLocal $ newTemp t-      -- This generic implementation is very simple and slow. We might-      -- well be able to do better, but for now this at least works.-      let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]-          toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]-          bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]-          add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]-          sum = foldl1 add-          mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y]-          or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]-          hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))-                               (wordWidth dflags))-          hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))-      emit $ catAGraphs-             [mkAssign xlyl-                  (mul (bottomHalf arg_x) (bottomHalf arg_y)),-              mkAssign xlyh-                  (mul (bottomHalf arg_x) (topHalf arg_y)),-              mkAssign xhyl-                  (mul (topHalf arg_x) (bottomHalf arg_y)),-              mkAssign r-                  (sum [topHalf    (CmmReg xlyl),-                        bottomHalf (CmmReg xhyl),-                        bottomHalf (CmmReg xlyh)]),-              mkAssign (CmmLocal res_l)-                  (or (bottomHalf (CmmReg xlyl))-                      (toTopHalf (CmmReg r))),-              mkAssign (CmmLocal res_h)-                  (sum [mul (topHalf arg_x) (topHalf arg_y),-                        topHalf (CmmReg xhyl),-                        topHalf (CmmReg xlyh),-                        topHalf (CmmReg r)])]-genericWordMul2Op _ _ = panic "genericWordMul2Op"---- This replicates what we had in libraries/base/GHC/Float.hs:------    abs x    | x == 0    = 0 -- handles (-0.0)---             | x >  0    = x---             | otherwise = negateFloat x-genericFabsOp :: Width -> GenericOp-genericFabsOp w [res_r] [aa]- = do dflags <- getDynFlags-      let zero   = CmmLit (CmmFloat 0 w)--          eq x y = CmmMachOp (MO_F_Eq w) [x, y]-          gt x y = CmmMachOp (MO_F_Gt w) [x, y]--          neg x  = CmmMachOp (MO_F_Neg w) [x]--          g1 = catAGraphs [mkAssign (CmmLocal res_r) zero]-          g2 = catAGraphs [mkAssign (CmmLocal res_r) aa]--      res_t <- CmmLocal <$> newTemp (cmmExprType dflags aa)-      let g3 = catAGraphs [mkAssign res_t aa,-                           mkAssign (CmmLocal res_r) (neg (CmmReg res_t))]--      g4 <- mkCmmIfThenElse (gt aa zero) g2 g3--      emit =<< mkCmmIfThenElse (eq aa zero) g1 g4--genericFabsOp _ _ _ = panic "genericFabsOp"---- These PrimOps are NOPs in Cmm--nopOp :: PrimOp -> Bool-nopOp Int2WordOp     = True-nopOp Word2IntOp     = True-nopOp Int2AddrOp     = True-nopOp Addr2IntOp     = True-nopOp ChrOp          = True  -- Int# and Char# are rep'd the same-nopOp OrdOp          = True-nopOp _              = False---- These PrimOps turn into double casts--narrowOp :: PrimOp -> Maybe (Width -> Width -> MachOp, Width)-narrowOp Narrow8IntOp   = Just (MO_SS_Conv, W8)-narrowOp Narrow16IntOp  = Just (MO_SS_Conv, W16)-narrowOp Narrow32IntOp  = Just (MO_SS_Conv, W32)-narrowOp Narrow8WordOp  = Just (MO_UU_Conv, W8)-narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16)-narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32)-narrowOp _              = Nothing---- Native word signless ops--translateOp :: DynFlags -> PrimOp -> Maybe MachOp-translateOp dflags IntAddOp       = Just (mo_wordAdd dflags)-translateOp dflags IntSubOp       = Just (mo_wordSub dflags)-translateOp dflags WordAddOp      = Just (mo_wordAdd dflags)-translateOp dflags WordSubOp      = Just (mo_wordSub dflags)-translateOp dflags AddrAddOp      = Just (mo_wordAdd dflags)-translateOp dflags AddrSubOp      = Just (mo_wordSub dflags)--translateOp dflags IntEqOp        = Just (mo_wordEq dflags)-translateOp dflags IntNeOp        = Just (mo_wordNe dflags)-translateOp dflags WordEqOp       = Just (mo_wordEq dflags)-translateOp dflags WordNeOp       = Just (mo_wordNe dflags)-translateOp dflags AddrEqOp       = Just (mo_wordEq dflags)-translateOp dflags AddrNeOp       = Just (mo_wordNe dflags)--translateOp dflags AndOp          = Just (mo_wordAnd dflags)-translateOp dflags OrOp           = Just (mo_wordOr dflags)-translateOp dflags XorOp          = Just (mo_wordXor dflags)-translateOp dflags NotOp          = Just (mo_wordNot dflags)-translateOp dflags SllOp          = Just (mo_wordShl dflags)-translateOp dflags SrlOp          = Just (mo_wordUShr dflags)--translateOp dflags AddrRemOp      = Just (mo_wordURem dflags)---- Native word signed ops--translateOp dflags IntMulOp        = Just (mo_wordMul dflags)-translateOp dflags IntMulMayOfloOp = Just (MO_S_MulMayOflo (wordWidth dflags))-translateOp dflags IntQuotOp       = Just (mo_wordSQuot dflags)-translateOp dflags IntRemOp        = Just (mo_wordSRem dflags)-translateOp dflags IntNegOp        = Just (mo_wordSNeg dflags)---translateOp dflags IntGeOp        = Just (mo_wordSGe dflags)-translateOp dflags IntLeOp        = Just (mo_wordSLe dflags)-translateOp dflags IntGtOp        = Just (mo_wordSGt dflags)-translateOp dflags IntLtOp        = Just (mo_wordSLt dflags)--translateOp dflags AndIOp         = Just (mo_wordAnd dflags)-translateOp dflags OrIOp          = Just (mo_wordOr dflags)-translateOp dflags XorIOp         = Just (mo_wordXor dflags)-translateOp dflags NotIOp         = Just (mo_wordNot dflags)-translateOp dflags ISllOp         = Just (mo_wordShl dflags)-translateOp dflags ISraOp         = Just (mo_wordSShr dflags)-translateOp dflags ISrlOp         = Just (mo_wordUShr dflags)---- Native word unsigned ops--translateOp dflags WordGeOp       = Just (mo_wordUGe dflags)-translateOp dflags WordLeOp       = Just (mo_wordULe dflags)-translateOp dflags WordGtOp       = Just (mo_wordUGt dflags)-translateOp dflags WordLtOp       = Just (mo_wordULt dflags)--translateOp dflags WordMulOp      = Just (mo_wordMul dflags)-translateOp dflags WordQuotOp     = Just (mo_wordUQuot dflags)-translateOp dflags WordRemOp      = Just (mo_wordURem dflags)--translateOp dflags AddrGeOp       = Just (mo_wordUGe dflags)-translateOp dflags AddrLeOp       = Just (mo_wordULe dflags)-translateOp dflags AddrGtOp       = Just (mo_wordUGt dflags)-translateOp dflags AddrLtOp       = Just (mo_wordULt dflags)---- Int8# signed ops--translateOp dflags Int8Extend     = Just (MO_SS_Conv W8 (wordWidth dflags))-translateOp dflags Int8Narrow     = Just (MO_SS_Conv (wordWidth dflags) W8)-translateOp _      Int8NegOp      = Just (MO_S_Neg W8)-translateOp _      Int8AddOp      = Just (MO_Add W8)-translateOp _      Int8SubOp      = Just (MO_Sub W8)-translateOp _      Int8MulOp      = Just (MO_Mul W8)-translateOp _      Int8QuotOp     = Just (MO_S_Quot W8)-translateOp _      Int8RemOp      = Just (MO_S_Rem W8)--translateOp _      Int8EqOp       = Just (MO_Eq W8)-translateOp _      Int8GeOp       = Just (MO_S_Ge W8)-translateOp _      Int8GtOp       = Just (MO_S_Gt W8)-translateOp _      Int8LeOp       = Just (MO_S_Le W8)-translateOp _      Int8LtOp       = Just (MO_S_Lt W8)-translateOp _      Int8NeOp       = Just (MO_Ne W8)---- Word8# unsigned ops--translateOp dflags Word8Extend     = Just (MO_UU_Conv W8 (wordWidth dflags))-translateOp dflags Word8Narrow     = Just (MO_UU_Conv (wordWidth dflags) W8)-translateOp _      Word8NotOp      = Just (MO_Not W8)-translateOp _      Word8AddOp      = Just (MO_Add W8)-translateOp _      Word8SubOp      = Just (MO_Sub W8)-translateOp _      Word8MulOp      = Just (MO_Mul W8)-translateOp _      Word8QuotOp     = Just (MO_U_Quot W8)-translateOp _      Word8RemOp      = Just (MO_U_Rem W8)--translateOp _      Word8EqOp       = Just (MO_Eq W8)-translateOp _      Word8GeOp       = Just (MO_U_Ge W8)-translateOp _      Word8GtOp       = Just (MO_U_Gt W8)-translateOp _      Word8LeOp       = Just (MO_U_Le W8)-translateOp _      Word8LtOp       = Just (MO_U_Lt W8)-translateOp _      Word8NeOp       = Just (MO_Ne W8)---- Int16# signed ops--translateOp dflags Int16Extend     = Just (MO_SS_Conv W16 (wordWidth dflags))-translateOp dflags Int16Narrow     = Just (MO_SS_Conv (wordWidth dflags) W16)-translateOp _      Int16NegOp      = Just (MO_S_Neg W16)-translateOp _      Int16AddOp      = Just (MO_Add W16)-translateOp _      Int16SubOp      = Just (MO_Sub W16)-translateOp _      Int16MulOp      = Just (MO_Mul W16)-translateOp _      Int16QuotOp     = Just (MO_S_Quot W16)-translateOp _      Int16RemOp      = Just (MO_S_Rem W16)--translateOp _      Int16EqOp       = Just (MO_Eq W16)-translateOp _      Int16GeOp       = Just (MO_S_Ge W16)-translateOp _      Int16GtOp       = Just (MO_S_Gt W16)-translateOp _      Int16LeOp       = Just (MO_S_Le W16)-translateOp _      Int16LtOp       = Just (MO_S_Lt W16)-translateOp _      Int16NeOp       = Just (MO_Ne W16)---- Word16# unsigned ops--translateOp dflags Word16Extend     = Just (MO_UU_Conv W16 (wordWidth dflags))-translateOp dflags Word16Narrow     = Just (MO_UU_Conv (wordWidth dflags) W16)-translateOp _      Word16NotOp      = Just (MO_Not W16)-translateOp _      Word16AddOp      = Just (MO_Add W16)-translateOp _      Word16SubOp      = Just (MO_Sub W16)-translateOp _      Word16MulOp      = Just (MO_Mul W16)-translateOp _      Word16QuotOp     = Just (MO_U_Quot W16)-translateOp _      Word16RemOp      = Just (MO_U_Rem W16)--translateOp _      Word16EqOp       = Just (MO_Eq W16)-translateOp _      Word16GeOp       = Just (MO_U_Ge W16)-translateOp _      Word16GtOp       = Just (MO_U_Gt W16)-translateOp _      Word16LeOp       = Just (MO_U_Le W16)-translateOp _      Word16LtOp       = Just (MO_U_Lt W16)-translateOp _      Word16NeOp       = Just (MO_Ne W16)---- Char# ops--translateOp dflags CharEqOp       = Just (MO_Eq (wordWidth dflags))-translateOp dflags CharNeOp       = Just (MO_Ne (wordWidth dflags))-translateOp dflags CharGeOp       = Just (MO_U_Ge (wordWidth dflags))-translateOp dflags CharLeOp       = Just (MO_U_Le (wordWidth dflags))-translateOp dflags CharGtOp       = Just (MO_U_Gt (wordWidth dflags))-translateOp dflags CharLtOp       = Just (MO_U_Lt (wordWidth dflags))---- Double ops--translateOp _      DoubleEqOp     = Just (MO_F_Eq W64)-translateOp _      DoubleNeOp     = Just (MO_F_Ne W64)-translateOp _      DoubleGeOp     = Just (MO_F_Ge W64)-translateOp _      DoubleLeOp     = Just (MO_F_Le W64)-translateOp _      DoubleGtOp     = Just (MO_F_Gt W64)-translateOp _      DoubleLtOp     = Just (MO_F_Lt W64)--translateOp _      DoubleAddOp    = Just (MO_F_Add W64)-translateOp _      DoubleSubOp    = Just (MO_F_Sub W64)-translateOp _      DoubleMulOp    = Just (MO_F_Mul W64)-translateOp _      DoubleDivOp    = Just (MO_F_Quot W64)-translateOp _      DoubleNegOp    = Just (MO_F_Neg W64)---- Float ops--translateOp _      FloatEqOp     = Just (MO_F_Eq W32)-translateOp _      FloatNeOp     = Just (MO_F_Ne W32)-translateOp _      FloatGeOp     = Just (MO_F_Ge W32)-translateOp _      FloatLeOp     = Just (MO_F_Le W32)-translateOp _      FloatGtOp     = Just (MO_F_Gt W32)-translateOp _      FloatLtOp     = Just (MO_F_Lt W32)--translateOp _      FloatAddOp    = Just (MO_F_Add  W32)-translateOp _      FloatSubOp    = Just (MO_F_Sub  W32)-translateOp _      FloatMulOp    = Just (MO_F_Mul  W32)-translateOp _      FloatDivOp    = Just (MO_F_Quot W32)-translateOp _      FloatNegOp    = Just (MO_F_Neg  W32)---- Vector ops--translateOp _ (VecAddOp FloatVec n w) = Just (MO_VF_Add  n w)-translateOp _ (VecSubOp FloatVec n w) = Just (MO_VF_Sub  n w)-translateOp _ (VecMulOp FloatVec n w) = Just (MO_VF_Mul  n w)-translateOp _ (VecDivOp FloatVec n w) = Just (MO_VF_Quot n w)-translateOp _ (VecNegOp FloatVec n w) = Just (MO_VF_Neg  n w)--translateOp _ (VecAddOp  IntVec n w) = Just (MO_V_Add   n w)-translateOp _ (VecSubOp  IntVec n w) = Just (MO_V_Sub   n w)-translateOp _ (VecMulOp  IntVec n w) = Just (MO_V_Mul   n w)-translateOp _ (VecQuotOp IntVec n w) = Just (MO_VS_Quot n w)-translateOp _ (VecRemOp  IntVec n w) = Just (MO_VS_Rem  n w)-translateOp _ (VecNegOp  IntVec n w) = Just (MO_VS_Neg  n w)--translateOp _ (VecAddOp  WordVec n w) = Just (MO_V_Add   n w)-translateOp _ (VecSubOp  WordVec n w) = Just (MO_V_Sub   n w)-translateOp _ (VecMulOp  WordVec n w) = Just (MO_V_Mul   n w)-translateOp _ (VecQuotOp WordVec n w) = Just (MO_VU_Quot n w)-translateOp _ (VecRemOp  WordVec n w) = Just (MO_VU_Rem  n w)---- Conversions--translateOp dflags Int2DoubleOp   = Just (MO_SF_Conv (wordWidth dflags) W64)-translateOp dflags Double2IntOp   = Just (MO_FS_Conv W64 (wordWidth dflags))--translateOp dflags Int2FloatOp    = Just (MO_SF_Conv (wordWidth dflags) W32)-translateOp dflags Float2IntOp    = Just (MO_FS_Conv W32 (wordWidth dflags))--translateOp _      Float2DoubleOp = Just (MO_FF_Conv W32 W64)-translateOp _      Double2FloatOp = Just (MO_FF_Conv W64 W32)---- Word comparisons masquerading as more exotic things.--translateOp dflags SameMutVarOp           = Just (mo_wordEq dflags)-translateOp dflags SameMVarOp             = Just (mo_wordEq dflags)-translateOp dflags SameMutableArrayOp     = Just (mo_wordEq dflags)-translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags)-translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags)-translateOp dflags SameSmallMutableArrayOp= Just (mo_wordEq dflags)-translateOp dflags SameTVarOp             = Just (mo_wordEq dflags)-translateOp dflags EqStablePtrOp          = Just (mo_wordEq dflags)--- See Note [Comparing stable names]-translateOp dflags EqStableNameOp         = Just (mo_wordEq dflags)--translateOp _      _ = Nothing---- Note [Comparing stable names]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ A StableName# is actually a pointer to a stable name object (SNO)--- containing an index into the stable name table (SNT). We--- used to compare StableName#s by following the pointers to the--- SNOs and checking whether they held the same SNT indices. However,--- this is not necessary: there is a one-to-one correspondence--- between SNOs and entries in the SNT, so simple pointer equality--- does the trick.---- These primops are implemented by CallishMachOps, because they sometimes--- turn into foreign calls depending on the backend.--callishOp :: PrimOp -> Maybe CallishMachOp-callishOp DoublePowerOp  = Just MO_F64_Pwr-callishOp DoubleSinOp    = Just MO_F64_Sin-callishOp DoubleCosOp    = Just MO_F64_Cos-callishOp DoubleTanOp    = Just MO_F64_Tan-callishOp DoubleSinhOp   = Just MO_F64_Sinh-callishOp DoubleCoshOp   = Just MO_F64_Cosh-callishOp DoubleTanhOp   = Just MO_F64_Tanh-callishOp DoubleAsinOp   = Just MO_F64_Asin-callishOp DoubleAcosOp   = Just MO_F64_Acos-callishOp DoubleAtanOp   = Just MO_F64_Atan-callishOp DoubleAsinhOp  = Just MO_F64_Asinh-callishOp DoubleAcoshOp  = Just MO_F64_Acosh-callishOp DoubleAtanhOp  = Just MO_F64_Atanh-callishOp DoubleLogOp    = Just MO_F64_Log-callishOp DoubleExpOp    = Just MO_F64_Exp-callishOp DoubleSqrtOp   = Just MO_F64_Sqrt--callishOp FloatPowerOp  = Just MO_F32_Pwr-callishOp FloatSinOp    = Just MO_F32_Sin-callishOp FloatCosOp    = Just MO_F32_Cos-callishOp FloatTanOp    = Just MO_F32_Tan-callishOp FloatSinhOp   = Just MO_F32_Sinh-callishOp FloatCoshOp   = Just MO_F32_Cosh-callishOp FloatTanhOp   = Just MO_F32_Tanh-callishOp FloatAsinOp   = Just MO_F32_Asin-callishOp FloatAcosOp   = Just MO_F32_Acos-callishOp FloatAtanOp   = Just MO_F32_Atan-callishOp FloatAsinhOp  = Just MO_F32_Asinh-callishOp FloatAcoshOp  = Just MO_F32_Acosh-callishOp FloatAtanhOp  = Just MO_F32_Atanh-callishOp FloatLogOp    = Just MO_F32_Log-callishOp FloatExpOp    = Just MO_F32_Exp-callishOp FloatSqrtOp   = Just MO_F32_Sqrt--callishOp _ = Nothing----------------------------------------------------------------------------------- Helpers for translating various minor variants of array indexing.--doIndexOffAddrOp :: Maybe MachOp-                 -> CmmType-                 -> [LocalReg]-                 -> [CmmExpr]-                 -> FCode ()-doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]-   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr rep idx-doIndexOffAddrOp _ _ _ _-   = panic "StgCmmPrim: doIndexOffAddrOp"--doIndexOffAddrOpAs :: Maybe MachOp-                   -> CmmType-                   -> CmmType-                   -> [LocalReg]-                   -> [CmmExpr]-                   -> FCode ()-doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]-   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx_rep idx-doIndexOffAddrOpAs _ _ _ _ _-   = panic "StgCmmPrim: doIndexOffAddrOpAs"--doIndexByteArrayOp :: Maybe MachOp-                   -> CmmType-                   -> [LocalReg]-                   -> [CmmExpr]-                   -> FCode ()-doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]-   = do dflags <- getDynFlags-        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr rep idx-doIndexByteArrayOp _ _ _ _-   = panic "StgCmmPrim: doIndexByteArrayOp"--doIndexByteArrayOpAs :: Maybe MachOp-                    -> CmmType-                    -> CmmType-                    -> [LocalReg]-                    -> [CmmExpr]-                    -> FCode ()-doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]-   = do dflags <- getDynFlags-        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx_rep idx-doIndexByteArrayOpAs _ _ _ _ _-   = panic "StgCmmPrim: doIndexByteArrayOpAs"--doReadPtrArrayOp :: LocalReg-                 -> CmmExpr-                 -> CmmExpr-                 -> FCode ()-doReadPtrArrayOp res addr idx-   = do dflags <- getDynFlags-        mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr (gcWord dflags) idx--doWriteOffAddrOp :: Maybe MachOp-                 -> CmmType-                 -> [LocalReg]-                 -> [CmmExpr]-                 -> FCode ()-doWriteOffAddrOp maybe_pre_write_cast idx_ty [] [addr,idx,val]-   = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val-doWriteOffAddrOp _ _ _ _-   = panic "StgCmmPrim: doWriteOffAddrOp"--doWriteByteArrayOp :: Maybe MachOp-                   -> CmmType-                   -> [LocalReg]-                   -> [CmmExpr]-                   -> FCode ()-doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val]-   = do dflags <- getDynFlags-        mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx_ty idx val-doWriteByteArrayOp _ _ _ _-   = panic "StgCmmPrim: doWriteByteArrayOp"--doWritePtrArrayOp :: CmmExpr-                  -> CmmExpr-                  -> CmmExpr-                  -> FCode ()-doWritePtrArrayOp addr idx val-  = do dflags <- getDynFlags-       let ty = cmmExprType dflags val-       -- This write barrier is to ensure that the heap writes to the object-       -- referred to by val have happened before we write val into the array.-       -- See #12469 for details.-       emitPrimCall [] MO_WriteBarrier []-       mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing addr ty idx val-       emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))-  -- the write barrier.  We must write a byte into the mark table:-  -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]-       emit $ mkStore (-         cmmOffsetExpr dflags-          (cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags))-                         (loadArrPtrsSize dflags addr))-          (CmmMachOp (mo_wordUShr dflags) [idx,-                                           mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)])-         ) (CmmLit (CmmInt 1 W8))--loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr-loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags)- where off = fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags--mkBasicIndexedRead :: ByteOff      -- Initial offset in bytes-                   -> Maybe MachOp -- Optional result cast-                   -> CmmType      -- Type of element we are accessing-                   -> LocalReg     -- Destination-                   -> CmmExpr      -- Base address-                   -> CmmType      -- Type of element by which we are indexing-                   -> CmmExpr      -- Index-                   -> FCode ()-mkBasicIndexedRead off Nothing ty res base idx_ty idx-   = do dflags <- getDynFlags-        emitAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off ty base idx_ty idx)-mkBasicIndexedRead off (Just cast) ty res base idx_ty idx-   = do dflags <- getDynFlags-        emitAssign (CmmLocal res) (CmmMachOp cast [-                                   cmmLoadIndexOffExpr dflags off ty base idx_ty idx])--mkBasicIndexedWrite :: ByteOff      -- Initial offset in bytes-                    -> Maybe MachOp -- Optional value cast-                    -> CmmExpr      -- Base address-                    -> CmmType      -- Type of element by which we are indexing-                    -> CmmExpr      -- Index-                    -> CmmExpr      -- Value to write-                    -> FCode ()-mkBasicIndexedWrite off Nothing base idx_ty idx val-   = do dflags <- getDynFlags-        emitStore (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) val-mkBasicIndexedWrite off (Just cast) base idx_ty idx val-   = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val])---- ------------------------------------------------------------------------------- Misc utils--cmmIndexOffExpr :: DynFlags-                -> ByteOff  -- Initial offset in bytes-                -> Width    -- Width of element by which we are indexing-                -> CmmExpr  -- Base address-                -> CmmExpr  -- Index-                -> CmmExpr-cmmIndexOffExpr dflags off width base idx-   = cmmIndexExpr dflags width (cmmOffsetB dflags base off) idx--cmmLoadIndexOffExpr :: DynFlags-                    -> ByteOff  -- Initial offset in bytes-                    -> CmmType  -- Type of element we are accessing-                    -> CmmExpr  -- Base address-                    -> CmmType  -- Type of element by which we are indexing-                    -> CmmExpr  -- Index-                    -> CmmExpr-cmmLoadIndexOffExpr dflags off ty base idx_ty idx-   = CmmLoad (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) ty--setInfo :: CmmExpr -> CmmExpr -> CmmAGraph-setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr----------------------------------------------------------------------------------- Helpers for translating vector primops.--vecVmmType :: PrimOpVecCat -> Length -> Width -> CmmType-vecVmmType pocat n w = vec n (vecCmmCat pocat w)--vecCmmCat :: PrimOpVecCat -> Width -> CmmType-vecCmmCat IntVec   = cmmBits-vecCmmCat WordVec  = cmmBits-vecCmmCat FloatVec = cmmFloat--vecElemInjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp-vecElemInjectCast _      FloatVec _   =  Nothing-vecElemInjectCast dflags IntVec   W8  =  Just (mo_WordTo8  dflags)-vecElemInjectCast dflags IntVec   W16 =  Just (mo_WordTo16 dflags)-vecElemInjectCast dflags IntVec   W32 =  Just (mo_WordTo32 dflags)-vecElemInjectCast _      IntVec   W64 =  Nothing-vecElemInjectCast dflags WordVec  W8  =  Just (mo_WordTo8  dflags)-vecElemInjectCast dflags WordVec  W16 =  Just (mo_WordTo16 dflags)-vecElemInjectCast dflags WordVec  W32 =  Just (mo_WordTo32 dflags)-vecElemInjectCast _      WordVec  W64 =  Nothing-vecElemInjectCast _      _        _   =  Nothing--vecElemProjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp-vecElemProjectCast _      FloatVec _   =  Nothing-vecElemProjectCast dflags IntVec   W8  =  Just (mo_s_8ToWord  dflags)-vecElemProjectCast dflags IntVec   W16 =  Just (mo_s_16ToWord dflags)-vecElemProjectCast dflags IntVec   W32 =  Just (mo_s_32ToWord dflags)-vecElemProjectCast _      IntVec   W64 =  Nothing-vecElemProjectCast dflags WordVec  W8  =  Just (mo_u_8ToWord  dflags)-vecElemProjectCast dflags WordVec  W16 =  Just (mo_u_16ToWord dflags)-vecElemProjectCast dflags WordVec  W32 =  Just (mo_u_32ToWord dflags)-vecElemProjectCast _      WordVec  W64 =  Nothing-vecElemProjectCast _      _        _   =  Nothing---- Check to make sure that we can generate code for the specified vector type--- given the current set of dynamic flags.-checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode ()-checkVecCompatibility dflags vcat l w = do-    when (hscTarget dflags /= HscLlvm) $ do-        sorry $ unlines ["SIMD vector instructions require the LLVM back-end."-                         ,"Please use -fllvm."]-    check vecWidth vcat l w-  where-    check :: Width -> PrimOpVecCat -> Length -> Width -> FCode ()-    check W128 FloatVec 4 W32 | not (isSseEnabled dflags) =-        sorry $ "128-bit wide single-precision floating point " ++-                "SIMD vector instructions require at least -msse."-    check W128 _ _ _ | not (isSse2Enabled dflags) =-        sorry $ "128-bit wide integer and double precision " ++-                "SIMD vector instructions require at least -msse2."-    check W256 FloatVec _ _ | not (isAvxEnabled dflags) =-        sorry $ "256-bit wide floating point " ++-                "SIMD vector instructions require at least -mavx."-    check W256 _ _ _ | not (isAvx2Enabled dflags) =-        sorry $ "256-bit wide integer " ++-                "SIMD vector instructions require at least -mavx2."-    check W512 _ _ _ | not (isAvx512fEnabled dflags) =-        sorry $ "512-bit wide " ++-                "SIMD vector instructions require -mavx512f."-    check _ _ _ _ = return ()--    vecWidth = typeWidth (vecVmmType vcat l w)----------------------------------------------------------------------------------- Helpers for translating vector packing and unpacking.--doVecPackOp :: Maybe MachOp  -- Cast from element to vector component-            -> CmmType       -- Type of vector-            -> CmmExpr       -- Initial vector-            -> [CmmExpr]     -- Elements-            -> CmmFormal     -- Destination for result-            -> FCode ()-doVecPackOp maybe_pre_write_cast ty z es res = do-    dst <- newTemp ty-    emitAssign (CmmLocal dst) z-    vecPack dst es 0-  where-    vecPack :: CmmFormal -> [CmmExpr] -> Int -> FCode ()-    vecPack src [] _ =-        emitAssign (CmmLocal res) (CmmReg (CmmLocal src))--    vecPack src (e : es) i = do-        dst <- newTemp ty-        if isFloatType (vecElemType ty)-          then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid)-                                                    [CmmReg (CmmLocal src), cast e, iLit])-          else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid)-                                                    [CmmReg (CmmLocal src), cast e, iLit])-        vecPack dst es (i + 1)-      where-        -- vector indices are always 32-bits-        iLit = CmmLit (CmmInt (toInteger i) W32)--    cast :: CmmExpr -> CmmExpr-    cast val = case maybe_pre_write_cast of-                 Nothing   -> val-                 Just cast -> CmmMachOp cast [val]--    len :: Length-    len = vecLength ty--    wid :: Width-    wid = typeWidth (vecElemType ty)--doVecUnpackOp :: Maybe MachOp  -- Cast from vector component to element result-              -> CmmType       -- Type of vector-              -> CmmExpr       -- Vector-              -> [CmmFormal]   -- Element results-              -> FCode ()-doVecUnpackOp maybe_post_read_cast ty e res =-    vecUnpack res 0-  where-    vecUnpack :: [CmmFormal] -> Int -> FCode ()-    vecUnpack [] _ =-        return ()--    vecUnpack (r : rs) i = do-        if isFloatType (vecElemType ty)-          then emitAssign (CmmLocal r) (cast (CmmMachOp (MO_VF_Extract len wid)-                                             [e, iLit]))-          else emitAssign (CmmLocal r) (cast (CmmMachOp (MO_V_Extract len wid)-                                             [e, iLit]))-        vecUnpack rs (i + 1)-      where-        -- vector indices are always 32-bits-        iLit = CmmLit (CmmInt (toInteger i) W32)--    cast :: CmmExpr -> CmmExpr-    cast val = case maybe_post_read_cast of-                 Nothing   -> val-                 Just cast -> CmmMachOp cast [val]--    len :: Length-    len = vecLength ty--    wid :: Width-    wid = typeWidth (vecElemType ty)--doVecInsertOp :: Maybe MachOp  -- Cast from element to vector component-              -> CmmType       -- Vector type-              -> CmmExpr       -- Source vector-              -> CmmExpr       -- Element-              -> CmmExpr       -- Index at which to insert element-              -> CmmFormal     -- Destination for result-              -> FCode ()-doVecInsertOp maybe_pre_write_cast ty src e idx res = do-    dflags <- getDynFlags-    -- vector indices are always 32-bits-    let idx' :: CmmExpr-        idx' = CmmMachOp (MO_SS_Conv (wordWidth dflags) W32) [idx]-    if isFloatType (vecElemType ty)-      then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, cast e, idx'])-      else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, cast e, idx'])-  where-    cast :: CmmExpr -> CmmExpr-    cast val = case maybe_pre_write_cast of-                 Nothing   -> val-                 Just cast -> CmmMachOp cast [val]--    len :: Length-    len = vecLength ty--    wid :: Width-    wid = typeWidth (vecElemType ty)----------------------------------------------------------------------------------- Helpers for translating prefetching.----- | Translate byte array prefetch operations into proper primcalls.-doPrefetchByteArrayOp :: Int-                      -> [CmmExpr]-                      -> FCode ()-doPrefetchByteArrayOp locality  [addr,idx]-   = do dflags <- getDynFlags-        mkBasicPrefetch locality (arrWordsHdrSize dflags)  addr idx-doPrefetchByteArrayOp _ _-   = panic "StgCmmPrim: doPrefetchByteArrayOp"---- | Translate mutable byte array prefetch operations into proper primcalls.-doPrefetchMutableByteArrayOp :: Int-                      -> [CmmExpr]-                      -> FCode ()-doPrefetchMutableByteArrayOp locality  [addr,idx]-   = do dflags <- getDynFlags-        mkBasicPrefetch locality (arrWordsHdrSize dflags)  addr idx-doPrefetchMutableByteArrayOp _ _-   = panic "StgCmmPrim: doPrefetchByteArrayOp"---- | Translate address prefetch operations into proper primcalls.-doPrefetchAddrOp ::Int-                 -> [CmmExpr]-                 -> FCode ()-doPrefetchAddrOp locality   [addr,idx]-   = mkBasicPrefetch locality 0  addr idx-doPrefetchAddrOp _ _-   = panic "StgCmmPrim: doPrefetchAddrOp"---- | Translate value prefetch operations into proper primcalls.-doPrefetchValueOp :: Int-                 -> [CmmExpr]-                 -> FCode ()-doPrefetchValueOp  locality   [addr]-  =  do dflags <- getDynFlags-        mkBasicPrefetch locality 0 addr  (CmmLit (CmmInt 0 (wordWidth dflags)))-doPrefetchValueOp _ _-  = panic "StgCmmPrim: doPrefetchValueOp"---- | helper to generate prefetch primcalls-mkBasicPrefetch :: Int          -- Locality level 0-3-                -> ByteOff      -- Initial offset in bytes-                -> CmmExpr      -- Base address-                -> CmmExpr      -- Index-                -> FCode ()-mkBasicPrefetch locality off base idx-   = do dflags <- getDynFlags-        emitPrimCall [] (MO_Prefetch_Data locality) [cmmIndexExpr dflags W8 (cmmOffsetB dflags base off) idx]-        return ()---- ------------------------------------------------------------------------------- Allocating byte arrays---- | Takes a register to return the newly allocated array in and the--- size of the new array in bytes. Allocates a new--- 'MutableByteArray#'.-doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode ()-doNewByteArrayOp res_r n = do-    dflags <- getDynFlags--    let info_ptr = mkLblExpr mkArrWords_infoLabel-        rep = arrWordsRep dflags n--    tickyAllocPrim (mkIntExpr dflags (arrWordsHdrSize dflags))-        (mkIntExpr dflags (nonHdrSize dflags rep))-        (zeroExpr dflags)--    let hdr_size = fixedHdrSize dflags--    base <- allocHeapClosure rep info_ptr cccsExpr-                     [ (mkIntExpr dflags n,-                        hdr_size + oFFSET_StgArrBytes_bytes dflags)-                     ]--    emit $ mkAssign (CmmLocal res_r) base---- ------------------------------------------------------------------------------- Comparing byte arrays--doCompareByteArraysOp :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr-                     -> FCode ()-doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do-    dflags <- getDynFlags-    ba1_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba1 (arrWordsHdrSize dflags)) ba1_off-    ba2_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba2 (arrWordsHdrSize dflags)) ba2_off--    -- short-cut in case of equal pointers avoiding a costly-    -- subroutine call to the memcmp(3) routine; the Cmm logic below-    -- results in assembly code being generated for-    ---    --   cmpPrefix10 :: ByteArray# -> ByteArray# -> Int#-    --   cmpPrefix10 ba1 ba2 = compareByteArrays# ba1 0# ba2 0# 10#-    ---    -- that looks like-    ---    --          leaq 16(%r14),%rax-    --          leaq 16(%rsi),%rbx-    --          xorl %ecx,%ecx-    --          cmpq %rbx,%rax-    --          je l_ptr_eq-    ---    --          ; NB: the common case (unequal pointers) falls-through-    --          ; the conditional jump, and therefore matches the-    --          ; usual static branch prediction convention of modern cpus-    ---    --          subq $8,%rsp-    --          movq %rbx,%rsi-    --          movq %rax,%rdi-    --          movl $10,%edx-    --          xorl %eax,%eax-    --          call memcmp-    --          addq $8,%rsp-    --          movslq %eax,%rax-    --          movq %rax,%rcx-    --  l_ptr_eq:-    --          movq %rcx,%rbx-    --          jmp *(%rbp)--    l_ptr_eq <- newBlockId-    l_ptr_ne <- newBlockId--    emit (mkAssign (CmmLocal res) (zeroExpr dflags))-    emit (mkCbranch (cmmEqWord dflags ba1_p ba2_p)-                    l_ptr_eq l_ptr_ne (Just False))--    emitLabel l_ptr_ne-    emitMemcmpCall res ba1_p ba2_p n 1--    emitLabel l_ptr_eq---- ------------------------------------------------------------------------------- Copying byte arrays---- | Takes a source 'ByteArray#', an offset in the source array, a--- destination 'MutableByteArray#', an offset into the destination--- array, and the number of bytes to copy.  Copies the given number of--- bytes from the source array to the destination array.-doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr-                  -> FCode ()-doCopyByteArrayOp = emitCopyByteArray copy-  where-    -- Copy data (we assume the arrays aren't overlapping since-    -- they're of different types)-    copy _src _dst dst_p src_p bytes =-        emitMemcpyCall dst_p src_p bytes 1---- | Takes a source 'MutableByteArray#', an offset in the source--- array, a destination 'MutableByteArray#', an offset into the--- destination array, and the number of bytes to copy.  Copies the--- given number of bytes from the source array to the destination--- array.-doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr-                         -> FCode ()-doCopyMutableByteArrayOp = emitCopyByteArray copy-  where-    -- The only time the memory might overlap is when the two arrays-    -- we were provided are the same array!-    -- TODO: Optimize branch for common case of no aliasing.-    copy src dst dst_p src_p bytes = do-        dflags <- getDynFlags-        (moveCall, cpyCall) <- forkAltPair-            (getCode $ emitMemmoveCall dst_p src_p bytes 1)-            (getCode $ emitMemcpyCall  dst_p src_p bytes 1)-        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall--emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr-                      -> FCode ())-                  -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr-                  -> FCode ()-emitCopyByteArray copy src src_off dst dst_off n = do-    dflags <- getDynFlags-    dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off-    src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off-    copy src dst dst_p src_p n---- | Takes a source 'ByteArray#', an offset in the source array, a--- destination 'Addr#', and the number of bytes to copy.  Copies the given--- number of bytes from the source array to the destination memory region.-doCopyByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()-doCopyByteArrayToAddrOp src src_off dst_p bytes = do-    -- Use memcpy (we are allowed to assume the arrays aren't overlapping)-    dflags <- getDynFlags-    src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off-    emitMemcpyCall dst_p src_p bytes 1---- | Takes a source 'MutableByteArray#', an offset in the source array, a--- destination 'Addr#', and the number of bytes to copy.  Copies the given--- number of bytes from the source array to the destination memory region.-doCopyMutableByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr-                               -> FCode ()-doCopyMutableByteArrayToAddrOp = doCopyByteArrayToAddrOp---- | Takes a source 'Addr#', a destination 'MutableByteArray#', an offset into--- the destination array, and the number of bytes to copy.  Copies the given--- number of bytes from the source memory region to the destination array.-doCopyAddrToByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()-doCopyAddrToByteArrayOp src_p dst dst_off bytes = do-    -- Use memcpy (we are allowed to assume the arrays aren't overlapping)-    dflags <- getDynFlags-    dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off-    emitMemcpyCall dst_p src_p bytes 1----- ------------------------------------------------------------------------------- Setting byte arrays---- | Takes a 'MutableByteArray#', an offset into the array, a length,--- and a byte, and sets each of the selected bytes in the array to the--- character.-doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr-                 -> FCode ()-doSetByteArrayOp ba off len c-    = do dflags <- getDynFlags-         p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off-         emitMemsetCall p c len 1---- ------------------------------------------------------------------------------- Allocating arrays---- | Allocate a new array.-doNewArrayOp :: CmmFormal             -- ^ return register-             -> SMRep                 -- ^ representation of the array-             -> CLabel                -- ^ info pointer-             -> [(CmmExpr, ByteOff)]  -- ^ header payload-             -> WordOff               -- ^ array size-             -> CmmExpr               -- ^ initial element-             -> FCode ()-doNewArrayOp res_r rep info payload n init = do-    dflags <- getDynFlags--    let info_ptr = mkLblExpr info--    tickyAllocPrim (mkIntExpr dflags (hdrSize dflags rep))-        (mkIntExpr dflags (nonHdrSize dflags rep))-        (zeroExpr dflags)--    base <- allocHeapClosure rep info_ptr cccsExpr payload--    arr <- CmmLocal `fmap` newTemp (bWord dflags)-    emit $ mkAssign arr base--    -- Initialise all elements of the array-    p <- assignTemp $ cmmOffsetB dflags (CmmReg arr) (hdrSize dflags rep)-    for <- newBlockId-    emitLabel for-    let loopBody =-            [ mkStore (CmmReg (CmmLocal p)) init-            , mkAssign (CmmLocal p) (cmmOffsetW dflags (CmmReg (CmmLocal p)) 1)-            , mkBranch for ]-    emit =<< mkCmmIfThen-        (cmmULtWord dflags (CmmReg (CmmLocal p))-         (cmmOffsetW dflags (CmmReg arr)-          (hdrSizeW dflags rep + n)))-        (catAGraphs loopBody)--    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)---- ------------------------------------------------------------------------------- Copying pointer arrays---- EZY: This code has an unusually high amount of assignTemp calls, seen--- nowhere else in the code generator.  This is mostly because these--- "primitive" ops result in a surprisingly large amount of code.  It--- will likely be worthwhile to optimize what is emitted here, so that--- our optimization passes don't waste time repeatedly optimizing the--- same bits of code.---- More closely imitates 'assignTemp' from the old code generator, which--- returns a CmmExpr rather than a LocalReg.-assignTempE :: CmmExpr -> FCode CmmExpr-assignTempE e = do-    t <- assignTemp e-    return (CmmReg (CmmLocal t))---- | Takes a source 'Array#', an offset in the source array, a--- destination 'MutableArray#', an offset into the destination array,--- and the number of elements to copy.  Copies the given number of--- elements from the source array to the destination array.-doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff-              -> FCode ()-doCopyArrayOp = emitCopyArray copy-  where-    -- Copy data (we assume the arrays aren't overlapping since-    -- they're of different types)-    copy _src _dst dst_p src_p bytes =-        do dflags <- getDynFlags-           emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)-               (wORD_SIZE dflags)----- | Takes a source 'MutableArray#', an offset in the source array, a--- destination 'MutableArray#', an offset into the destination array,--- and the number of elements to copy.  Copies the given number of--- elements from the source array to the destination array.-doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff-                     -> FCode ()-doCopyMutableArrayOp = emitCopyArray copy-  where-    -- The only time the memory might overlap is when the two arrays-    -- we were provided are the same array!-    -- TODO: Optimize branch for common case of no aliasing.-    copy src dst dst_p src_p bytes = do-        dflags <- getDynFlags-        (moveCall, cpyCall) <- forkAltPair-            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)-             (wORD_SIZE dflags))-            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)-             (wORD_SIZE dflags))-        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall--emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff-                  -> FCode ())  -- ^ copy function-              -> CmmExpr        -- ^ source array-              -> CmmExpr        -- ^ offset in source array-              -> CmmExpr        -- ^ destination array-              -> CmmExpr        -- ^ offset in destination array-              -> WordOff        -- ^ number of elements to copy-              -> FCode ()-emitCopyArray copy src0 src_off dst0 dst_off0 n = do-    dflags <- getDynFlags-    when (n /= 0) $ do-        -- Passed as arguments (be careful)-        src     <- assignTempE src0-        dst     <- assignTempE dst0-        dst_off <- assignTempE dst_off0--        -- Set the dirty bit in the header.-        emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))--        dst_elems_p <- assignTempE $ cmmOffsetB dflags dst-                       (arrPtrsHdrSize dflags)-        dst_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p dst_off-        src_p <- assignTempE $ cmmOffsetExprW dflags-                 (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off-        let bytes = wordsToBytes dflags n--        copy src dst dst_p src_p bytes--        -- The base address of the destination card table-        dst_cards_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p-                       (loadArrPtrsSize dflags dst)--        emitSetCards dst_off dst_cards_p n--doCopySmallArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff-                   -> FCode ()-doCopySmallArrayOp = emitCopySmallArray copy-  where-    -- Copy data (we assume the arrays aren't overlapping since-    -- they're of different types)-    copy _src _dst dst_p src_p bytes =-        do dflags <- getDynFlags-           emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)-               (wORD_SIZE dflags)---doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff-                          -> FCode ()-doCopySmallMutableArrayOp = emitCopySmallArray copy-  where-    -- The only time the memory might overlap is when the two arrays-    -- we were provided are the same array!-    -- TODO: Optimize branch for common case of no aliasing.-    copy src dst dst_p src_p bytes = do-        dflags <- getDynFlags-        (moveCall, cpyCall) <- forkAltPair-            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)-             (wORD_SIZE dflags))-            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)-             (wORD_SIZE dflags))-        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall--emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff-                       -> FCode ())  -- ^ copy function-                   -> CmmExpr        -- ^ source array-                   -> CmmExpr        -- ^ offset in source array-                   -> CmmExpr        -- ^ destination array-                   -> CmmExpr        -- ^ offset in destination array-                   -> WordOff        -- ^ number of elements to copy-                   -> FCode ()-emitCopySmallArray copy src0 src_off dst0 dst_off n = do-    dflags <- getDynFlags--    -- Passed as arguments (be careful)-    src     <- assignTempE src0-    dst     <- assignTempE dst0--    -- Set the dirty bit in the header.-    emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))--    dst_p <- assignTempE $ cmmOffsetExprW dflags-             (cmmOffsetB dflags dst (smallArrPtrsHdrSize dflags)) dst_off-    src_p <- assignTempE $ cmmOffsetExprW dflags-             (cmmOffsetB dflags src (smallArrPtrsHdrSize dflags)) src_off-    let bytes = wordsToBytes dflags n--    copy src dst dst_p src_p bytes---- | Takes an info table label, a register to return the newly--- allocated array in, a source array, an offset in the source array,--- and the number of elements to copy. Allocates a new array and--- initializes it from the source array.-emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff-               -> FCode ()-emitCloneArray info_p res_r src src_off n = do-    dflags <- getDynFlags--    let info_ptr = mkLblExpr info_p-        rep = arrPtrsRep dflags n--    tickyAllocPrim (mkIntExpr dflags (arrPtrsHdrSize dflags))-        (mkIntExpr dflags (nonHdrSize dflags rep))-        (zeroExpr dflags)--    let hdr_size = fixedHdrSize dflags--    base <- allocHeapClosure rep info_ptr cccsExpr-                     [ (mkIntExpr dflags n,-                        hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags)-                     , (mkIntExpr dflags (nonHdrSizeW rep),-                        hdr_size + oFFSET_StgMutArrPtrs_size dflags)-                     ]--    arr <- CmmLocal `fmap` newTemp (bWord dflags)-    emit $ mkAssign arr base--    dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr)-             (arrPtrsHdrSize dflags)-    src_p <- assignTempE $ cmmOffsetExprW dflags src-             (cmmAddWord dflags-              (mkIntExpr dflags (arrPtrsHdrSizeW dflags)) src_off)--    emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))-        (wORD_SIZE dflags)--    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)---- | Takes an info table label, a register to return the newly--- allocated array in, a source array, an offset in the source array,--- and the number of elements to copy. Allocates a new array and--- initializes it from the source array.-emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff-                    -> FCode ()-emitCloneSmallArray info_p res_r src src_off n = do-    dflags <- getDynFlags--    let info_ptr = mkLblExpr info_p-        rep = smallArrPtrsRep n--    tickyAllocPrim (mkIntExpr dflags (smallArrPtrsHdrSize dflags))-        (mkIntExpr dflags (nonHdrSize dflags rep))-        (zeroExpr dflags)--    let hdr_size = fixedHdrSize dflags--    base <- allocHeapClosure rep info_ptr cccsExpr-                     [ (mkIntExpr dflags n,-                        hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags)-                     ]--    arr <- CmmLocal `fmap` newTemp (bWord dflags)-    emit $ mkAssign arr base--    dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr)-             (smallArrPtrsHdrSize dflags)-    src_p <- assignTempE $ cmmOffsetExprW dflags src-             (cmmAddWord dflags-              (mkIntExpr dflags (smallArrPtrsHdrSizeW dflags)) src_off)--    emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))-        (wORD_SIZE dflags)--    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)---- | Takes and offset in the destination array, the base address of--- the card table, and the number of elements affected (*not* the--- number of cards). The number of elements may not be zero.--- Marks the relevant cards as dirty.-emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode ()-emitSetCards dst_start dst_cards_start n = do-    dflags <- getDynFlags-    start_card <- assignTempE $ cardCmm dflags dst_start-    let end_card = cardCmm dflags-                   (cmmSubWord dflags-                    (cmmAddWord dflags dst_start (mkIntExpr dflags n))-                    (mkIntExpr dflags 1))-    emitMemsetCall (cmmAddWord dflags dst_cards_start start_card)-        (mkIntExpr dflags 1)-        (cmmAddWord dflags (cmmSubWord dflags end_card start_card) (mkIntExpr dflags 1))-        1 -- no alignment (1 byte)---- Convert an element index to a card index-cardCmm :: DynFlags -> CmmExpr -> CmmExpr-cardCmm dflags i =-    cmmUShrWord dflags i (mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags))----------------------------------------------------------------------------------- SmallArray PrimOp implementations--doReadSmallPtrArrayOp :: LocalReg-                      -> CmmExpr-                      -> CmmExpr-                      -> FCode ()-doReadSmallPtrArrayOp res addr idx = do-    dflags <- getDynFlags-    mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr-        (gcWord dflags) idx--doWriteSmallPtrArrayOp :: CmmExpr-                       -> CmmExpr-                       -> CmmExpr-                       -> FCode ()-doWriteSmallPtrArrayOp addr idx val = do-    dflags <- getDynFlags-    let ty = cmmExprType dflags val-    emitPrimCall [] MO_WriteBarrier [] -- #12469-    mkBasicIndexedWrite (smallArrPtrsHdrSize dflags) Nothing addr ty idx val-    emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))----------------------------------------------------------------------------------- Atomic read-modify-write---- | Emit an atomic modification to a byte array element. The result--- reg contains that previous value of the element. Implies a full--- memory barrier.-doAtomicRMW :: LocalReg      -- ^ Result reg-            -> AtomicMachOp  -- ^ Atomic op (e.g. add)-            -> CmmExpr       -- ^ MutableByteArray#-            -> CmmExpr       -- ^ Index-            -> CmmType       -- ^ Type of element by which we are indexing-            -> CmmExpr       -- ^ Op argument (e.g. amount to add)-            -> FCode ()-doAtomicRMW res amop mba idx idx_ty n = do-    dflags <- getDynFlags-    let width = typeWidth idx_ty-        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)-                width mba idx-    emitPrimCall-        [ res ]-        (MO_AtomicRMW width amop)-        [ addr, n ]---- | Emit an atomic read to a byte array that acts as a memory barrier.-doAtomicReadByteArray-    :: LocalReg  -- ^ Result reg-    -> CmmExpr   -- ^ MutableByteArray#-    -> CmmExpr   -- ^ Index-    -> CmmType   -- ^ Type of element by which we are indexing-    -> FCode ()-doAtomicReadByteArray res mba idx idx_ty = do-    dflags <- getDynFlags-    let width = typeWidth idx_ty-        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)-                width mba idx-    emitPrimCall-        [ res ]-        (MO_AtomicRead width)-        [ addr ]---- | Emit an atomic write to a byte array that acts as a memory barrier.-doAtomicWriteByteArray-    :: CmmExpr   -- ^ MutableByteArray#-    -> CmmExpr   -- ^ Index-    -> CmmType   -- ^ Type of element by which we are indexing-    -> CmmExpr   -- ^ Value to write-    -> FCode ()-doAtomicWriteByteArray mba idx idx_ty val = do-    dflags <- getDynFlags-    let width = typeWidth idx_ty-        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)-                width mba idx-    emitPrimCall-        [ {- no results -} ]-        (MO_AtomicWrite width)-        [ addr, val ]--doCasByteArray-    :: LocalReg  -- ^ Result reg-    -> CmmExpr   -- ^ MutableByteArray#-    -> CmmExpr   -- ^ Index-    -> CmmType   -- ^ Type of element by which we are indexing-    -> CmmExpr   -- ^ Old value-    -> CmmExpr   -- ^ New value-    -> FCode ()-doCasByteArray res mba idx idx_ty old new = do-    dflags <- getDynFlags-    let width = (typeWidth idx_ty)-        addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)-               width mba idx-    emitPrimCall-        [ res ]-        (MO_Cmpxchg width)-        [ addr, old, new ]----------------------------------------------------------------------------------- Helpers for emitting function calls---- | Emit a call to @memcpy@.-emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()-emitMemcpyCall dst src n align = do-    emitPrimCall-        [ {-no results-} ]-        (MO_Memcpy align)-        [ dst, src, n ]---- | Emit a call to @memmove@.-emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()-emitMemmoveCall dst src n align = do-    emitPrimCall-        [ {- no results -} ]-        (MO_Memmove align)-        [ dst, src, n ]---- | Emit a call to @memset@.  The second argument must fit inside an--- unsigned char.-emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()-emitMemsetCall dst c n align = do-    emitPrimCall-        [ {- no results -} ]-        (MO_Memset align)-        [ dst, c, n ]--emitMemcmpCall :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()-emitMemcmpCall res ptr1 ptr2 n align = do-    -- 'MO_Memcmp' is assumed to return an 32bit 'CInt' because all-    -- code-gens currently call out to the @memcmp(3)@ C function.-    -- This was easier than moving the sign-extensions into-    -- all the code-gens.-    dflags <- getDynFlags-    let is32Bit = typeWidth (localRegType res) == W32--    cres <- if is32Bit-              then return res-              else newTemp b32--    emitPrimCall-        [ cres ]-        (MO_Memcmp align)-        [ ptr1, ptr2, n ]--    unless is32Bit $ do-      emit $ mkAssign (CmmLocal res)-                      (CmmMachOp-                         (mo_s_32ToWord dflags)-                         [(CmmReg (CmmLocal cres))])--emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode ()-emitBSwapCall res x width = do-    emitPrimCall-        [ res ]-        (MO_BSwap width)-        [ x ]--emitPopCntCall :: LocalReg -> CmmExpr -> Width -> FCode ()-emitPopCntCall res x width = do-    emitPrimCall-        [ res ]-        (MO_PopCnt width)-        [ x ]--emitPdepCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()-emitPdepCall res x y width = do-    emitPrimCall-        [ res ]-        (MO_Pdep width)-        [ x, y ]--emitPextCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()-emitPextCall res x y width = do-    emitPrimCall-        [ res ]-        (MO_Pext width)-        [ x, y ]--emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode ()-emitClzCall res x width = do-    emitPrimCall-        [ res ]-        (MO_Clz width)-        [ x ]--emitCtzCall :: LocalReg -> CmmExpr -> Width -> FCode ()-emitCtzCall res x width = do-    emitPrimCall-        [ res ]-        (MO_Ctz width)-        [ x ]
− compiler/codeGen/StgCmmProf.hs 
@@ -1,360 +0,0 @@------------------------------------------------------------------------------------ Code generation for profiling------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module StgCmmProf (-        initCostCentres, ccType, ccsType,-        mkCCostCentre, mkCCostCentreStack,--        -- Cost-centre Profiling-        dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,-        enterCostCentreThunk, enterCostCentreFun,-        costCentreFrom,-        storeCurCCS,-        emitSetCCC,--        saveCurrentCostCentre, restoreCurrentCostCentre,--        -- Lag/drag/void stuff-        ldvEnter, ldvEnterClosure, ldvRecordCreate-  ) where--import GhcPrelude--import StgCmmClosure-import StgCmmUtils-import StgCmmMonad-import SMRep--import MkGraph-import Cmm-import CmmUtils-import CLabel--import CostCentre-import DynFlags-import FastString-import Module-import Outputable--import Control.Monad-import Data.Char (ord)------------------------------------------------------------------------------------- Cost-centre-stack Profiling------------------------------------------------------------------------------------- Expression representing the current cost centre stack-ccsType :: DynFlags -> CmmType -- Type of a cost-centre stack-ccsType = bWord--ccType :: DynFlags -> CmmType -- Type of a cost centre-ccType = bWord--storeCurCCS :: CmmExpr -> CmmAGraph-storeCurCCS e = mkAssign cccsReg e--mkCCostCentre :: CostCentre -> CmmLit-mkCCostCentre cc = CmmLabel (mkCCLabel cc)--mkCCostCentreStack :: CostCentreStack -> CmmLit-mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)--costCentreFrom :: DynFlags-               -> CmmExpr         -- A closure pointer-               -> CmmExpr        -- The cost centre from that closure-costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags)---- | The profiling header words in a static closure-staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]-staticProfHdr dflags ccs- = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags]---- | Profiling header words in a dynamic closure-dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]-dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags]---- | Initialise the profiling field of an update frame-initUpdFrameProf :: CmmExpr -> FCode ()-initUpdFrameProf frame-  = ifProfiling $        -- frame->header.prof.ccs = CCCS-    do dflags <- getDynFlags-       emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) cccsExpr-        -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)-        -- is unnecessary because it is not used anyhow.--------------------------------------------------------------------------------         Saving and restoring the current cost centre------------------------------------------------------------------------------{-        Note [Saving the current cost centre]-        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The current cost centre is like a global register.  Like other-global registers, it's a caller-saves one.  But consider-        case (f x) of (p,q) -> rhs-Since 'f' may set the cost centre, we must restore it-before resuming rhs.  So we want code like this:-        local_cc = CCC  -- save-        r = f( x )-        CCC = local_cc  -- restore-That is, we explicitly "save" the current cost centre in-a LocalReg, local_cc; and restore it after the call. The-C-- infrastructure will arrange to save local_cc across the-call.--The same goes for join points;-        let j x = join-stuff-        in blah-blah-We want this kind of code:-        local_cc = CCC  -- save-        blah-blah-     J:-        CCC = local_cc  -- restore--}--saveCurrentCostCentre :: FCode (Maybe LocalReg)-        -- Returns Nothing if profiling is off-saveCurrentCostCentre-  = do dflags <- getDynFlags-       if not (gopt Opt_SccProfilingOn dflags)-           then return Nothing-           else do local_cc <- newTemp (ccType dflags)-                   emitAssign (CmmLocal local_cc) cccsExpr-                   return (Just local_cc)--restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()-restoreCurrentCostCentre Nothing-  = return ()-restoreCurrentCostCentre (Just local_cc)-  = emit (storeCurCCS (CmmReg (CmmLocal local_cc)))------------------------------------------------------------------------------------- Recording allocation in a cost centre------------------------------------------------------------------------------------ | Record the allocation of a closure.  The CmmExpr is the cost--- centre stack to which to attribute the allocation.-profDynAlloc :: SMRep -> CmmExpr -> FCode ()-profDynAlloc rep ccs-  = ifProfiling $-    do dflags <- getDynFlags-       profAlloc (mkIntExpr dflags (heapClosureSizeW dflags rep)) ccs---- | Record the allocation of a closure (size is given by a CmmExpr)--- The size must be in words, because the allocation counter in a CCS counts--- in words.-profAlloc :: CmmExpr -> CmmExpr -> FCode ()-profAlloc words ccs-  = ifProfiling $-        do dflags <- getDynFlags-           let alloc_rep = rEP_CostCentreStack_mem_alloc dflags-           emit (addToMemE alloc_rep-                       (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags))-                       (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $-                         [CmmMachOp (mo_wordSub dflags) [words,-                                                         mkIntExpr dflags (profHdrSize dflags)]]))-                       -- subtract the "profiling overhead", which is the-                       -- profiling header in a closure.---- -------------------------------------------------------------------------- Setting the current cost centre on entry to a closure--enterCostCentreThunk :: CmmExpr -> FCode ()-enterCostCentreThunk closure =-  ifProfiling $ do-      dflags <- getDynFlags-      emit $ storeCurCCS (costCentreFrom dflags closure)--enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()-enterCostCentreFun ccs closure =-  ifProfiling $ do-    if isCurrentCCS ccs-       then do dflags <- getDynFlags-               emitRtsCall rtsUnitId (fsLit "enterFunCCS")-                   [(baseExpr, AddrHint),-                    (costCentreFrom dflags closure, AddrHint)] False-       else return () -- top-level function, nothing to do--ifProfiling :: FCode () -> FCode ()-ifProfiling code-  = do dflags <- getDynFlags-       if gopt Opt_SccProfilingOn dflags-           then code-           else return ()--ifProfilingL :: DynFlags -> [a] -> [a]-ifProfilingL dflags xs-  | gopt Opt_SccProfilingOn dflags = xs-  | otherwise                      = []---------------------------------------------------------------------        Initialising Cost Centres & CCSs------------------------------------------------------------------initCostCentres :: CollectedCCs -> FCode ()--- Emit the declarations-initCostCentres (local_CCs, singleton_CCSs)-  = do dflags <- getDynFlags-       when (gopt Opt_SccProfilingOn dflags) $-           do mapM_ emitCostCentreDecl local_CCs-              mapM_ emitCostCentreStackDecl singleton_CCSs---emitCostCentreDecl :: CostCentre -> FCode ()-emitCostCentreDecl cc = do-  { dflags <- getDynFlags-  ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF-               | otherwise  = zero dflags-                        -- NB. bytesFS: we want the UTF-8 bytes here (#5559)-  ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)-  ; modl  <- newByteStringCLit (bytesFS $ Module.moduleNameFS-                                        $ Module.moduleName-                                        $ cc_mod cc)-  ; loc <- newByteStringCLit $ bytesFS $ mkFastString $-                   showPpr dflags (costCentreSrcSpan cc)-           -- XXX going via FastString to get UTF-8 encoding is silly-  ; let-     lits = [ zero dflags,           -- StgInt ccID,-              label,        -- char *label,-              modl,        -- char *module,-              loc,      -- char *srcloc,-              zero64,   -- StgWord64 mem_alloc-              zero dflags,     -- StgWord time_ticks-              is_caf,   -- StgInt is_caf-              zero dflags      -- struct _CostCentre *link-            ]-  ; emitDataLits (mkCCLabel cc) lits-  }--emitCostCentreStackDecl :: CostCentreStack -> FCode ()-emitCostCentreStackDecl ccs-  = case maybeSingletonCCS ccs of-    Just cc ->-        do dflags <- getDynFlags-           let mk_lits cc = zero dflags :-                            mkCCostCentre cc :-                            replicate (sizeof_ccs_words dflags - 2) (zero dflags)-                -- Note: to avoid making any assumptions about how the-                -- C compiler (that compiles the RTS, in particular) does-                -- layouts of structs containing long-longs, simply-                -- pad out the struct with zero words until we hit the-                -- size of the overall struct (which we get via GhclibDerivedConstants.h)-           emitDataLits (mkCCSLabel ccs) (mk_lits cc)-    Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)--zero :: DynFlags -> CmmLit-zero dflags = mkIntCLit dflags 0-zero64 :: CmmLit-zero64 = CmmInt 0 W64--sizeof_ccs_words :: DynFlags -> Int-sizeof_ccs_words dflags-    -- round up to the next word.-  | ms == 0   = ws-  | otherwise = ws + 1-  where-   (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags---- ------------------------------------------------------------------------------ Set the current cost centre stack--emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()-emitSetCCC cc tick push- = do dflags <- getDynFlags-      if not (gopt Opt_SccProfilingOn dflags)-          then return ()-          else do tmp <- newTemp (ccsType dflags)-                  pushCostCentre tmp cccsExpr cc-                  when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))-                  when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))--pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()-pushCostCentre result ccs cc-  = emitRtsCallWithResult result AddrHint-        rtsUnitId-        (fsLit "pushCostCentre") [(ccs,AddrHint),-                                (CmmLit (mkCCostCentre cc), AddrHint)]-        False--bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph-bumpSccCount dflags ccs-  = addToMem (rEP_CostCentreStack_scc_count dflags)-         (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1-------------------------------------------------------------------------------------                Lag/drag/void stuff---------------------------------------------------------------------------------------- Initial value for the LDV field in a static closure----staticLdvInit :: DynFlags -> CmmLit-staticLdvInit = zeroCLit------- Initial value of the LDV field in a dynamic closure----dynLdvInit :: DynFlags -> CmmExpr-dynLdvInit dflags =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE-  CmmMachOp (mo_wordOr dflags) [-      CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)],-      CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags))-  ]------- Initialise the LDV word of a new closure----ldvRecordCreate :: CmmExpr -> FCode ()-ldvRecordCreate closure = do-  dflags <- getDynFlags-  emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags)------- | Called when a closure is entered, marks the closure as having--- been "used".  The closure is not an "inherently used" one.  The--- closure is not @IND@ because that is not considered for LDV profiling.----ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode ()-ldvEnterClosure closure_info node_reg = do-    dflags <- getDynFlags-    let tag = funTag dflags closure_info-    -- don't forget to substract node's tag-    ldvEnter (cmmOffsetB dflags (CmmReg node_reg) (-tag))--ldvEnter :: CmmExpr -> FCode ()--- Argument is a closure pointer-ldvEnter cl_ptr = do-    dflags <- getDynFlags-    let -- don't forget to substract node's tag-        ldv_wd = ldvWord dflags cl_ptr-        new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))-                                                         (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags))))-                                      (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags))))-    ifProfiling $-         -- if (era > 0) {-         --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |-         --                era | LDV_STATE_USE }-        emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)])-                     (mkStore ldv_wd new_ldv_wd)-                     mkNop--loadEra :: DynFlags -> CmmExpr-loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags))-    [CmmLoad (mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "era")))-             (cInt dflags)]--ldvWord :: DynFlags -> CmmExpr -> CmmExpr--- Takes the address of a closure, and returns--- the address of the LDV word in the closure-ldvWord dflags closure_ptr-    = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags)
− compiler/codeGen/StgCmmTicky.hs 
@@ -1,682 +0,0 @@-{-# LANGUAGE BangPatterns #-}------------------------------------------------------------------------------------- Code generation for ticky-ticky profiling------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------{- OVERVIEW: ticky ticky profiling--Please see-http://ghc.haskell.org/trac/ghc/wiki/Debugging/TickyTicky and also-edit it and the rest of this comment to keep them up-to-date if you-change ticky-ticky. Thanks!-- *** All allocation ticky numbers are in bytes. ***--Some of the relevant source files:--       ***not necessarily an exhaustive list***--  * some codeGen/ modules import this one--  * this module imports cmm/CLabel.hs to manage labels--  * cmm/CmmParse.y expands some macros using generators defined in-    this module--  * includes/stg/Ticky.h declares all of the global counters--  * includes/rts/Ticky.h declares the C data type for an-    STG-declaration's counters--  * some macros defined in includes/Cmm.h (and used within the RTS's-    CMM code) update the global ticky counters--  * at the end of execution rts/Ticky.c generates the final report-    +RTS -r<report-file> -RTS--The rts/Ticky.c function that generates the report includes an-STG-declaration's ticky counters if--  * that declaration was entered, or--  * it was allocated (if -ticky-allocd)--On either of those events, the counter is "registered" by adding it to-a linked list; cf the CMM generated by registerTickyCtr.--Ticky-ticky profiling has evolved over many years. Many of the-counters from its most sophisticated days are no longer-active/accurate. As the RTS has changed, sometimes the ticky code for-relevant counters was not accordingly updated. Unfortunately, neither-were the comments.--As of March 2013, there still exist deprecated code and comments in-the code generator as well as the RTS because:--  * I don't know what is out-of-date versus merely commented out for-    momentary convenience, and--  * someone else might know how to repair it!---}--module StgCmmTicky (-  withNewTickyCounterFun,-  withNewTickyCounterLNE,-  withNewTickyCounterThunk,-  withNewTickyCounterStdThunk,-  withNewTickyCounterCon,--  tickyDynAlloc,-  tickyAllocHeap,--  tickyAllocPrim,-  tickyAllocThunk,-  tickyAllocPAP,-  tickyHeapCheck,-  tickyStackCheck,--  tickyUnknownCall, tickyDirectCall,--  tickyPushUpdateFrame,-  tickyUpdateFrameOmitted,--  tickyEnterDynCon,-  tickyEnterStaticCon,-  tickyEnterViaNode,--  tickyEnterFun,-  tickyEnterThunk, tickyEnterStdThunk,        -- dynamic non-value-                                              -- thunks only-  tickyEnterLNE,--  tickyUpdateBhCaf,-  tickyBlackHole,-  tickyUnboxedTupleReturn,-  tickyReturnOldCon, tickyReturnNewCon,--  tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,-  tickySlowCall, tickySlowCallPat,-  ) where--import GhcPrelude--import StgCmmArgRep    ( slowCallPattern , toArgRep , argRepString )-import StgCmmClosure-import StgCmmUtils-import StgCmmMonad--import StgSyn-import CmmExpr-import MkGraph-import CmmUtils-import CLabel-import SMRep--import Module-import Name-import Id-import BasicTypes-import FastString-import Outputable-import Util--import DynFlags---- Turgid imports for showTypeCategory-import PrelNames-import TcType-import Type-import TyCon--import Data.Maybe-import qualified Data.Char-import Control.Monad ( when )------------------------------------------------------------------------------------- Ticky-ticky profiling-----------------------------------------------------------------------------------data TickyClosureType-    = TickyFun-        Bool -- True <-> single entry-    | TickyCon-    | TickyThunk-        Bool -- True <-> updateable-        Bool -- True <-> standard thunk (AP or selector), has no entry counter-    | TickyLNE--withNewTickyCounterFun :: Bool -> Name  -> [NonVoid Id] -> FCode a -> FCode a-withNewTickyCounterFun single_entry = withNewTickyCounter (TickyFun single_entry)--withNewTickyCounterLNE :: Name  -> [NonVoid Id] -> FCode a -> FCode a-withNewTickyCounterLNE nm args code = do-  b <- tickyLNEIsOn-  if not b then code else withNewTickyCounter TickyLNE nm args code--thunkHasCounter :: Bool -> FCode Bool-thunkHasCounter isStatic = do-  b <- tickyDynThunkIsOn-  pure (not isStatic && b)--withNewTickyCounterThunk-  :: Bool -- ^ static-  -> Bool -- ^ updateable-  -> Name-  -> FCode a-  -> FCode a-withNewTickyCounterThunk isStatic isUpdatable name code = do-    has_ctr <- thunkHasCounter isStatic-    if not has_ctr-      then code-      else withNewTickyCounter (TickyThunk isUpdatable False) name [] code--withNewTickyCounterStdThunk-  :: Bool -- ^ updateable-  -> Name-  -> FCode a-  -> FCode a-withNewTickyCounterStdThunk isUpdatable name code = do-    has_ctr <- thunkHasCounter False-    if not has_ctr-      then code-      else withNewTickyCounter (TickyThunk isUpdatable True) name [] code--withNewTickyCounterCon-  :: Name-  -> FCode a-  -> FCode a-withNewTickyCounterCon name code = do-    has_ctr <- thunkHasCounter False-    if not has_ctr-      then code-      else withNewTickyCounter TickyCon name [] code---- args does not include the void arguments-withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a-withNewTickyCounter cloType name args m = do-  lbl <- emitTickyCounter cloType name args-  setTickyCtrLabel lbl m--emitTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode CLabel-emitTickyCounter cloType name args-  = let ctr_lbl = mkRednCountsLabel name in-    (>> return ctr_lbl) $-    ifTicky $ do-        { dflags <- getDynFlags-        ; parent <- getTickyCtrLabel-        ; mod_name <- getModuleName--          -- When printing the name of a thing in a ticky file, we-          -- want to give the module name even for *local* things.  We-          -- print just "x (M)" rather that "M.x" to distinguish them-          -- from the global kind.-        ; let ppr_for_ticky_name :: SDoc-              ppr_for_ticky_name =-                let n = ppr name-                    ext = case cloType of-                              TickyFun single_entry -> parens $ hcat $ punctuate comma $-                                  [text "fun"] ++ [text "se"|single_entry]-                              TickyCon -> parens (text "con")-                              TickyThunk upd std -> parens $ hcat $ punctuate comma $-                                  [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std]-                              TickyLNE | isInternalName name -> parens (text "LNE")-                                       | otherwise -> panic "emitTickyCounter: how is this an external LNE?"-                    p = case hasHaskellName parent of-                            -- NB the default "top" ticky ctr does not-                            -- have a Haskell name-                          Just pname -> text "in" <+> ppr (nameUnique pname)-                          _ -> empty-                in if isInternalName name-                   then n <+> parens (ppr mod_name) <+> ext <+> p-                   else n <+> ext <+> p--        ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name-        ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args-        ; emitDataLits ctr_lbl-        -- Must match layout of includes/rts/Ticky.h's StgEntCounter-        ---        -- krc: note that all the fields are I32 now; some were I16-        -- before, but the code generator wasn't handling that-        -- properly and it led to chaos, panic and disorder.-            [ mkIntCLit dflags 0,               -- registered?-              mkIntCLit dflags (length args),   -- Arity-              mkIntCLit dflags 0,               -- Heap allocated for this thing-              fun_descr_lit,-              arg_descr_lit,-              zeroCLit dflags,          -- Entries into this thing-              zeroCLit dflags,          -- Heap allocated by this thing-              zeroCLit dflags                   -- Link to next StgEntCounter-            ]-        }---- -------------------------------------------------------------------------------- Ticky stack frames--tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode ()-tickyPushUpdateFrame    = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr")-tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")---- -------------------------------------------------------------------------------- Ticky entries---- NB the name-specific entries are only available for names that have--- dedicated Cmm code. As far as I know, this just rules out--- constructor thunks. For them, there is no CMM code block to put the--- bump of name-specific ticky counter into. On the other hand, we can--- still track allocation their allocation.--tickyEnterDynCon, tickyEnterStaticCon, tickyEnterViaNode :: FCode ()-tickyEnterDynCon      = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")-tickyEnterStaticCon   = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr")-tickyEnterViaNode     = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr")--tickyEnterThunk :: ClosureInfo -> FCode ()-tickyEnterThunk cl_info-  = ifTicky $ do-    { bumpTickyCounter ctr-    ; has_ctr <- thunkHasCounter static-    ; when has_ctr $ do-      ticky_ctr_lbl <- getTickyCtrLabel-      registerTickyCtrAtEntryDyn ticky_ctr_lbl-      bumpTickyEntryCount ticky_ctr_lbl }-  where-    updatable = closureSingleEntry cl_info-    static    = isStaticClosure cl_info--    ctr | static    = if updatable then fsLit "ENT_STATIC_THK_SINGLE_ctr"-                                   else fsLit "ENT_STATIC_THK_MANY_ctr"-        | otherwise = if updatable then fsLit "ENT_DYN_THK_SINGLE_ctr"-                                   else fsLit "ENT_DYN_THK_MANY_ctr"--tickyEnterStdThunk :: ClosureInfo -> FCode ()-tickyEnterStdThunk = tickyEnterThunk--tickyBlackHole :: Bool{-updatable-} -> FCode ()-tickyBlackHole updatable-  = ifTicky (bumpTickyCounter ctr)-  where-    ctr | updatable = (fsLit "UPD_BH_SINGLE_ENTRY_ctr")-        | otherwise = (fsLit "UPD_BH_UPDATABLE_ctr")--tickyUpdateBhCaf :: ClosureInfo -> FCode ()-tickyUpdateBhCaf cl_info-  = ifTicky (bumpTickyCounter ctr)-  where-    ctr | closureUpdReqd cl_info = (fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr")-        | otherwise              = (fsLit "UPD_CAF_BH_UPDATABLE_ctr")--tickyEnterFun :: ClosureInfo -> FCode ()-tickyEnterFun cl_info = ifTicky $ do-  ctr_lbl <- getTickyCtrLabel--  if isStaticClosure cl_info-    then do bumpTickyCounter (fsLit "ENT_STATIC_FUN_DIRECT_ctr")-            registerTickyCtr ctr_lbl-    else do bumpTickyCounter (fsLit "ENT_DYN_FUN_DIRECT_ctr")-            registerTickyCtrAtEntryDyn ctr_lbl--  bumpTickyEntryCount ctr_lbl--tickyEnterLNE :: FCode ()-tickyEnterLNE = ifTicky $ do-  bumpTickyCounter (fsLit "ENT_LNE_ctr")-  ifTickyLNE $ do-    ctr_lbl <- getTickyCtrLabel-    registerTickyCtr ctr_lbl-    bumpTickyEntryCount ctr_lbl---- needn't register a counter upon entry if------ 1) it's for a dynamic closure, and------ 2) -ticky-allocd is on------ since the counter was registered already upon being alloc'd-registerTickyCtrAtEntryDyn :: CLabel -> FCode ()-registerTickyCtrAtEntryDyn ctr_lbl = do-  already_registered <- tickyAllocdIsOn-  when (not already_registered) $ registerTickyCtr ctr_lbl--registerTickyCtr :: CLabel -> FCode ()--- Register a ticky counter---   if ( ! f_ct.registeredp ) {---          f_ct.link = ticky_entry_ctrs;       /* hook this one onto the front of the list */---          ticky_entry_ctrs = & (f_ct);        /* mark it as "registered" */---          f_ct.registeredp = 1 }-registerTickyCtr ctr_lbl = do-  dflags <- getDynFlags-  let-    -- krc: code generator doesn't handle Not, so we test for Eq 0 instead-    test = CmmMachOp (MO_Eq (wordWidth dflags))-              [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl-                                (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags),-               zeroExpr dflags]-    register_stmts-      = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags)))-                   (CmmLoad ticky_entry_ctrs (bWord dflags))-        , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl)-        , mkStore (CmmLit (cmmLabelOffB ctr_lbl-                                (oFFSET_StgEntCounter_registeredp dflags)))-                   (mkIntExpr dflags 1) ]-    ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "ticky_entry_ctrs"))-  emit =<< mkCmmIfThen test (catAGraphs register_stmts)--tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()-tickyReturnOldCon arity-  = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr")-                 ; bumpHistogram    (fsLit "RET_OLD_hst") arity }-tickyReturnNewCon arity-  = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr")-                 ; bumpHistogram    (fsLit "RET_NEW_hst") arity }--tickyUnboxedTupleReturn :: RepArity -> FCode ()-tickyUnboxedTupleReturn arity-  = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")-                 ; bumpHistogram    (fsLit "RET_UNBOXED_TUP_hst") arity }---- -------------------------------------------------------------------------------- Ticky calls---- Ticks at a *call site*:-tickyDirectCall :: RepArity -> [StgArg] -> FCode ()-tickyDirectCall arity args-  | args `lengthIs` arity = tickyKnownCallExact-  | otherwise = do tickyKnownCallExtraArgs-                   tickySlowCallPat (map argPrimRep (drop arity args))--tickyKnownCallTooFewArgs :: FCode ()-tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")--tickyKnownCallExact :: FCode ()-tickyKnownCallExact      = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr")--tickyKnownCallExtraArgs :: FCode ()-tickyKnownCallExtraArgs  = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr")--tickyUnknownCall :: FCode ()-tickyUnknownCall         = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr")---- Tick for the call pattern at slow call site (i.e. in addition to--- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)-tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()-tickySlowCall _ [] = return ()-tickySlowCall lf_info args = do- -- see Note [Ticky for slow calls]- if isKnownFun lf_info-   then tickyKnownCallTooFewArgs-   else tickyUnknownCall- tickySlowCallPat (map argPrimRep args)--tickySlowCallPat :: [PrimRep] -> FCode ()-tickySlowCallPat args = ifTicky $-  let argReps = map toArgRep args-      (_, n_matched) = slowCallPattern argReps-  in if n_matched > 0 && args `lengthIs` n_matched-     then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps-     else bumpTickyCounter $ fsLit "VERY_SLOW_CALL_ctr"--{---Note [Ticky for slow calls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Terminology is unfortunately a bit mixed up for these calls. codeGen-uses "slow call" to refer to unknown calls and under-saturated known-calls.--Nowadays, though (ie as of the eval/apply paper), the significantly-slower calls are actually just a subset of these: the ones with no-built-in argument pattern (cf StgCmmArgRep.slowCallPattern)--So for ticky profiling, we split slow calls into-"SLOW_CALL_fast_<pattern>_ctr" (those matching a built-in pattern) and-VERY_SLOW_CALL_ctr (those without a built-in pattern; these are very-bad for both space and time).---}---- -------------------------------------------------------------------------------- Ticky allocation--tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()--- Called when doing a dynamic heap allocation; the LambdaFormInfo--- used to distinguish between closure types------ TODO what else to count while we're here?-tickyDynAlloc mb_id rep lf = ifTicky $ getDynFlags >>= \dflags ->-  let bytes = wORD_SIZE dflags * heapClosureSizeW dflags rep--      countGlobal tot ctr = do-        bumpTickyCounterBy tot bytes-        bumpTickyCounter   ctr-      countSpecific = ifTickyAllocd $ case mb_id of-        Nothing -> return ()-        Just id -> do-          let ctr_lbl = mkRednCountsLabel (idName id)-          registerTickyCtr ctr_lbl-          bumpTickyAllocd ctr_lbl bytes--  -- TODO are we still tracking "good stuff" (_gds) versus-  -- administrative (_adm) versus slop (_slp)? I'm going with all _gds-  -- for now, since I don't currently know neither if we do nor how to-  -- distinguish. NSF Mar 2013--  in case () of-    _ | isConRep rep   ->-          ifTickyDynThunk countSpecific >>-          countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr")-      | isThunkRep rep ->-          ifTickyDynThunk countSpecific >>-          if lfUpdatable lf-          then countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_UP_THK_ctr")-          else countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_SE_THK_ctr")-      | isFunRep   rep ->-          countSpecific >>-          countGlobal (fsLit "ALLOC_FUN_gds") (fsLit "ALLOC_FUN_ctr")-      | otherwise      -> panic "How is this heap object not a con, thunk, or fun?"----tickyAllocHeap ::-  Bool -> -- is this a genuine allocation? As opposed to-          -- StgCmmLayout.adjustHpBackwards-  VirtualHpOffset -> FCode ()--- Called when doing a heap check [TICK_ALLOC_HEAP]--- Must be lazy in the amount of allocation!-tickyAllocHeap genuine hp-  = ifTicky $-    do  { dflags <- getDynFlags-        ; ticky_ctr <- getTickyCtrLabel-        ; emit $ catAGraphs $-            -- only test hp from within the emit so that the monadic-            -- computation itself is not strict in hp (cf knot in-            -- StgCmmMonad.getHeapUsage)-          if hp == 0 then []-          else let !bytes = wORD_SIZE dflags * hp in [-            -- Bump the allocation total in the closure's StgEntCounter-            addToMem (rEP_StgEntCounter_allocs dflags)-                     (CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags)))-                     bytes,-            -- Bump the global allocation total ALLOC_HEAP_tot-            addToMemLbl (bWord dflags)-                        (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_tot"))-                        bytes,-            -- Bump the global allocation counter ALLOC_HEAP_ctr-            if not genuine then mkNop-            else addToMemLbl (bWord dflags)-                             (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_ctr"))-                             1-            ]}-------------------------------------------------------------------------------------- these three are only called from CmmParse.y (ie ultimately from the RTS)---- the units are bytes--tickyAllocPrim :: CmmExpr  -- ^ size of the full header, in bytes-               -> CmmExpr  -- ^ size of the payload, in bytes-               -> CmmExpr -> FCode ()-tickyAllocPrim _hdr _goods _slop = ifTicky $ do-  bumpTickyCounter    (fsLit "ALLOC_PRIM_ctr")-  bumpTickyCounterByE (fsLit "ALLOC_PRIM_adm") _hdr-  bumpTickyCounterByE (fsLit "ALLOC_PRIM_gds") _goods-  bumpTickyCounterByE (fsLit "ALLOC_PRIM_slp") _slop--tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()-tickyAllocThunk _goods _slop = ifTicky $ do-    -- TODO is it ever called with a Single-Entry thunk?-  bumpTickyCounter    (fsLit "ALLOC_UP_THK_ctr")-  bumpTickyCounterByE (fsLit "ALLOC_THK_gds") _goods-  bumpTickyCounterByE (fsLit "ALLOC_THK_slp") _slop--tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()-tickyAllocPAP _goods _slop = ifTicky $ do-  bumpTickyCounter    (fsLit "ALLOC_PAP_ctr")-  bumpTickyCounterByE (fsLit "ALLOC_PAP_gds") _goods-  bumpTickyCounterByE (fsLit "ALLOC_PAP_slp") _slop--tickyHeapCheck :: FCode ()-tickyHeapCheck = ifTicky $ bumpTickyCounter (fsLit "HEAP_CHK_ctr")--tickyStackCheck :: FCode ()-tickyStackCheck = ifTicky $ bumpTickyCounter (fsLit "STK_CHK_ctr")---- -------------------------------------------------------------------------------- Ticky utils--ifTicky :: FCode () -> FCode ()-ifTicky code =-  getDynFlags >>= \dflags -> when (gopt Opt_Ticky dflags) code--tickyAllocdIsOn :: FCode Bool-tickyAllocdIsOn = gopt Opt_Ticky_Allocd `fmap` getDynFlags--tickyLNEIsOn :: FCode Bool-tickyLNEIsOn = gopt Opt_Ticky_LNE `fmap` getDynFlags--tickyDynThunkIsOn :: FCode Bool-tickyDynThunkIsOn = gopt Opt_Ticky_Dyn_Thunk `fmap` getDynFlags--ifTickyAllocd :: FCode () -> FCode ()-ifTickyAllocd code = tickyAllocdIsOn >>= \b -> when b code--ifTickyLNE :: FCode () -> FCode ()-ifTickyLNE code = tickyLNEIsOn >>= \b -> when b code--ifTickyDynThunk :: FCode () -> FCode ()-ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code--bumpTickyCounter :: FastString -> FCode ()-bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsUnitId lbl)--bumpTickyCounterBy :: FastString -> Int -> FCode ()-bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsUnitId lbl)--bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()-bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsUnitId lbl)--bumpTickyEntryCount :: CLabel -> FCode ()-bumpTickyEntryCount lbl = do-  dflags <- getDynFlags-  bumpTickyLit (cmmLabelOffB lbl (oFFSET_StgEntCounter_entry_count dflags))--bumpTickyAllocd :: CLabel -> Int -> FCode ()-bumpTickyAllocd lbl bytes = do-  dflags <- getDynFlags-  bumpTickyLitBy (cmmLabelOffB lbl (oFFSET_StgEntCounter_allocd dflags)) bytes--bumpTickyLbl :: CLabel -> FCode ()-bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1--bumpTickyLblBy :: CLabel -> Int -> FCode ()-bumpTickyLblBy lhs = bumpTickyLitBy (cmmLabelOffB lhs 0)--bumpTickyLblByE :: CLabel -> CmmExpr -> FCode ()-bumpTickyLblByE lhs = bumpTickyLitByE (cmmLabelOffB lhs 0)--bumpTickyLit :: CmmLit -> FCode ()-bumpTickyLit lhs = bumpTickyLitBy lhs 1--bumpTickyLitBy :: CmmLit -> Int -> FCode ()-bumpTickyLitBy lhs n = do-  dflags <- getDynFlags-  emit (addToMem (bWord dflags) (CmmLit lhs) n)--bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()-bumpTickyLitByE lhs e = do-  dflags <- getDynFlags-  emit (addToMemE (bWord dflags) (CmmLit lhs) e)--bumpHistogram :: FastString -> Int -> FCode ()-bumpHistogram lbl n = do-    dflags <- getDynFlags-    let offset = n `min` (tICKY_BIN_COUNT dflags - 1)-    emit (addToMem (bWord dflags)-           (cmmIndexExpr dflags-                (wordWidth dflags)-                (CmmLit (CmmLabel (mkCmmDataLabel rtsUnitId lbl)))-                (CmmLit (CmmInt (fromIntegral offset) (wordWidth dflags))))-           1)----------------------------------------------------------------------- Showing the "type category" for ticky-ticky profiling--showTypeCategory :: Type -> Char-  {--        +           dictionary--        >           function--        {C,I,F,D,W} char, int, float, double, word-        {c,i,f,d,w} unboxed ditto--        T           tuple--        P           other primitive type-        p           unboxed ditto--        L           list-        E           enumeration type-        S           other single-constructor type-        M           other multi-constructor data-con type--        .           other type--        -           reserved for others to mark as "uninteresting"--  Accurate as of Mar 2013, but I eliminated the Array category instead-  of updating it, for simplicity. It's in P/p, I think --NSF--    -}-showTypeCategory ty-  | isDictTy ty = '+'-  | otherwise = case tcSplitTyConApp_maybe ty of-  Nothing -> '.'-  Just (tycon, _) ->-    (if isUnliftedTyCon tycon then Data.Char.toLower else id) $-    let anyOf us = getUnique tycon `elem` us in-    case () of-      _ | anyOf [funTyConKey] -> '>'-        | anyOf [charPrimTyConKey, charTyConKey] -> 'C'-        | anyOf [doublePrimTyConKey, doubleTyConKey] -> 'D'-        | anyOf [floatPrimTyConKey, floatTyConKey] -> 'F'-        | anyOf [intPrimTyConKey, int32PrimTyConKey, int64PrimTyConKey,-                 intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey-                ] -> 'I'-        | anyOf [wordPrimTyConKey, word32PrimTyConKey, word64PrimTyConKey, wordTyConKey,-                 word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey-                ] -> 'W'-        | anyOf [listTyConKey] -> 'L'-        | isTupleTyCon tycon       -> 'T'-        | isPrimTyCon tycon        -> 'P'-        | isEnumerationTyCon tycon -> 'E'-        | isJust (tyConSingleDataCon_maybe tycon) -> 'S'-        | otherwise -> 'M' -- oh, well...
− compiler/codeGen/StgCmmUtils.hs 
@@ -1,622 +0,0 @@-{-# LANGUAGE CPP #-}------------------------------------------------------------------------------------- Code generator utilities; mostly monadic------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module StgCmmUtils (-        cgLit, mkSimpleLit,-        emitDataLits, mkDataLits,-        emitRODataLits, mkRODataLits,-        emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,-        assignTemp, newTemp,--        newUnboxedTupleRegs,--        emitMultiAssign, emitCmmLitSwitch, emitSwitch,--        tagToClosure, mkTaggedObjectLoad,--        callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,--        cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,-        cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,-        cmmOffsetExprW, cmmOffsetExprB,-        cmmRegOffW, cmmRegOffB,-        cmmLabelOffW, cmmLabelOffB,-        cmmOffsetW, cmmOffsetB,-        cmmOffsetLitW, cmmOffsetLitB,-        cmmLoadIndexW,-        cmmConstrTag1,--        cmmUntag, cmmIsTagged,--        addToMem, addToMemE, addToMemLblE, addToMemLbl,-        mkWordCLit,-        newStringCLit, newByteStringCLit,-        blankWord,-  ) where--#include "GhclibHsVersions.h"--import GhcPrelude--import StgCmmMonad-import StgCmmClosure-import Cmm-import BlockId-import MkGraph-import CodeGen.Platform-import CLabel-import CmmUtils-import CmmSwitch--import ForeignCall-import IdInfo-import Type-import TyCon-import SMRep-import Module-import Literal-import Digraph-import Util-import Unique-import UniqSupply (MonadUnique(..))-import DynFlags-import FastString-import Outputable-import RepType--import qualified Data.ByteString as BS-import qualified Data.Map as M-import Data.Char-import Data.List-import Data.Ord-import Data.Word----------------------------------------------------------------------------------      Literals-------------------------------------------------------------------------------cgLit :: Literal -> FCode CmmLit-cgLit (LitString s) = newByteStringCLit (BS.unpack s)- -- not unpackFS; we want the UTF-8 byte stream.-cgLit other_lit     = do dflags <- getDynFlags-                         return (mkSimpleLit dflags other_lit)--mkSimpleLit :: DynFlags -> Literal -> CmmLit-mkSimpleLit dflags (LitChar   c)                = CmmInt (fromIntegral (ord c))-                                                         (wordWidth dflags)-mkSimpleLit dflags LitNullAddr                  = zeroCLit dflags-mkSimpleLit dflags (LitNumber LitNumInt i _)    = CmmInt i (wordWidth dflags)-mkSimpleLit _      (LitNumber LitNumInt64 i _)  = CmmInt i W64-mkSimpleLit dflags (LitNumber LitNumWord i _)   = CmmInt i (wordWidth dflags)-mkSimpleLit _      (LitNumber LitNumWord64 i _) = CmmInt i W64-mkSimpleLit _      (LitFloat r)                 = CmmFloat r W32-mkSimpleLit _      (LitDouble r)                = CmmFloat r W64-mkSimpleLit _      (LitLabel fs ms fod)-  = let -- TODO: Literal labels might not actually be in the current package...-        labelSrc = ForeignLabelInThisPackage-    in CmmLabel (mkForeignLabel fs ms labelSrc fod)--- NB: LitRubbish should have been lowered in "CoreToStg"-mkSimpleLit _      other = pprPanic "mkSimpleLit" (ppr other)---------------------------------------------------------------------------------- Incrementing a memory location--------------------------------------------------------------------------------addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph-addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n--addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph-addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl))--addToMem :: CmmType     -- rep of the counter-         -> CmmExpr     -- Address-         -> Int         -- What to add (a word)-         -> CmmAGraph-addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep)))--addToMemE :: CmmType    -- rep of the counter-          -> CmmExpr    -- Address-          -> CmmExpr    -- What to add (a word-typed expression)-          -> CmmAGraph-addToMemE rep ptr n-  = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])----------------------------------------------------------------------------------      Loading a field from an object,---      where the object pointer is itself tagged-------------------------------------------------------------------------------mkTaggedObjectLoad-  :: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph--- (loadTaggedObjectField reg base off tag) generates assignment---      reg = bitsK[ base + off - tag ]--- where K is fixed by 'reg'-mkTaggedObjectLoad dflags reg base offset tag-  = mkAssign (CmmLocal reg)-             (CmmLoad (cmmOffsetB dflags-                                  (CmmReg (CmmLocal base))-                                  (offset - tag))-                      (localRegType reg))---------------------------------------------------------------------------------      Converting a closure tag to a closure for enumeration types---      (this is the implementation of tagToEnum#).-------------------------------------------------------------------------------tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr-tagToClosure dflags tycon tag-  = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (bWord dflags)-  where closure_tbl = CmmLit (CmmLabel lbl)-        lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs---------------------------------------------------------------------------------      Conditionals and rts calls-------------------------------------------------------------------------------emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()-emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe--emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString-        -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()-emitRtsCallWithResult res hint pkg fun args safe-   = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe---- Make a call to an RTS C procedure-emitRtsCallGen-   :: [(LocalReg,ForeignHint)]-   -> CLabel-   -> [(CmmExpr,ForeignHint)]-   -> Bool -- True <=> CmmSafe call-   -> FCode ()-emitRtsCallGen res lbl args safe-  = do { dflags <- getDynFlags-       ; updfr_off <- getUpdFrameOff-       ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags-       ; emit caller_save-       ; call updfr_off-       ; emit caller_load }-  where-    call updfr_off =-      if safe then-        emit =<< mkCmmCall fun_expr res' args' updfr_off-      else do-        let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn-        emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'-    (args', arg_hints) = unzip args-    (res',  res_hints) = unzip res-    fun_expr = mkLblExpr lbl--------------------------------------------------------------------------------------      Caller-Save Registers------------------------------------------------------------------------------------- Here we generate the sequence of saves/restores required around a--- foreign call instruction.---- TODO: reconcile with includes/Regs.h---  * Regs.h claims that BaseReg should be saved last and loaded first---    * This might not have been tickled before since BaseReg is callee save---  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim------ This code isn't actually used right now, because callerSaves--- only ever returns true in the current universe for registers NOT in--- system_regs (just do a grep for CALLER_SAVES in--- includes/stg/MachRegs.h).  It's all one giant no-op, and for--- good reason: having to save system registers on every foreign call--- would be very expensive, so we avoid assigning them to those--- registers when we add support for an architecture.------ Note that the old code generator actually does more work here: it--- also saves other global registers.  We can't (nor want) to do that--- here, as we don't have liveness information.  And really, we--- shouldn't be doing the workaround at this point in the pipeline, see--- Note [Register parameter passing] and the ToDo on CmmCall in--- cmm/CmmNode.hs.  Right now the workaround is to avoid inlining across--- unsafe foreign calls in rewriteAssignments, but this is strictly--- temporary.-callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph)-callerSaveVolatileRegs dflags = (caller_save, caller_load)-  where-    platform = targetPlatform dflags--    caller_save = catAGraphs (map callerSaveGlobalReg    regs_to_save)-    caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)--    system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery-                    {- ,SparkHd,SparkTl,SparkBase,SparkLim -}-                  , BaseReg ]--    regs_to_save = filter (callerSaves platform) system_regs--    callerSaveGlobalReg reg-        = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))--    callerRestoreGlobalReg reg-        = mkAssign (CmmGlobal reg)-                   (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg))---- -------------------------------------------------------------------------------- Global registers---- We map STG registers onto appropriate CmmExprs.  Either they map--- to real machine registers or stored as offsets from BaseReg.  Given--- a GlobalReg, get_GlobalReg_addr always produces the--- register table address for it.--- (See also get_GlobalReg_reg_or_addr in MachRegs)--get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr-get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0-get_GlobalReg_addr dflags mid-    = get_Regtable_addr_from_offset dflags-                                    (globalRegType dflags mid) (baseRegOffset dflags mid)---- Calculate a literal representing an offset into the register table.--- Used when we don't have an actual BaseReg to offset from.-regTableOffset :: DynFlags -> Int -> CmmExpr-regTableOffset dflags n =-  CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))--get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr-get_Regtable_addr_from_offset dflags _rep offset =-    if haveRegBase (targetPlatform dflags)-    then CmmRegOff baseReg offset-    else regTableOffset dflags offset----- -------------------------------------------------------------------------------- Information about global registers--baseRegOffset :: DynFlags -> GlobalReg -> Int--baseRegOffset dflags Sp             = oFFSET_StgRegTable_rSp dflags-baseRegOffset dflags SpLim          = oFFSET_StgRegTable_rSpLim dflags-baseRegOffset dflags (LongReg 1)    = oFFSET_StgRegTable_rL1 dflags-baseRegOffset dflags Hp             = oFFSET_StgRegTable_rHp dflags-baseRegOffset dflags HpLim          = oFFSET_StgRegTable_rHpLim dflags-baseRegOffset dflags CCCS           = oFFSET_StgRegTable_rCCCS dflags-baseRegOffset dflags CurrentTSO     = oFFSET_StgRegTable_rCurrentTSO dflags-baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags-baseRegOffset dflags HpAlloc        = oFFSET_StgRegTable_rHpAlloc dflags-baseRegOffset dflags GCEnter1       = oFFSET_stgGCEnter1 dflags-baseRegOffset dflags GCFun          = oFFSET_stgGCFun dflags-baseRegOffset _      reg            = pprPanic "StgCmmUtils.baseRegOffset:" (ppr reg)---------------------------------------------------------------------------------      Strings generate a top-level data block-------------------------------------------------------------------------------emitDataLits :: CLabel -> [CmmLit] -> FCode ()--- Emit a data-segment data block-emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits)--emitRODataLits :: CLabel -> [CmmLit] -> FCode ()--- Emit a read-only data block-emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)--newStringCLit :: String -> FCode CmmLit--- Make a global definition for the string,--- and return its label-newStringCLit str = newByteStringCLit (map (fromIntegral . ord) str)--newByteStringCLit :: [Word8] -> FCode CmmLit-newByteStringCLit bytes-  = do  { uniq <- newUnique-        ; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes-        ; emitDecl decl-        ; return lit }---------------------------------------------------------------------------------      Assigning expressions to temporaries-------------------------------------------------------------------------------assignTemp :: CmmExpr -> FCode LocalReg--- Make sure the argument is in a local register.--- We don't bother being particularly aggressive with avoiding--- unnecessary local registers, since we can rely on a later--- optimization pass to inline as necessary (and skipping out--- on things like global registers can be a little dangerous--- due to them being trashed on foreign calls--though it means--- the optimization pass doesn't have to do as much work)-assignTemp (CmmReg (CmmLocal reg)) = return reg-assignTemp e = do { dflags <- getDynFlags-                  ; uniq <- newUnique-                  ; let reg = LocalReg uniq (cmmExprType dflags e)-                  ; emitAssign (CmmLocal reg) e-                  ; return reg }--newTemp :: MonadUnique m => CmmType -> m LocalReg-newTemp rep = do { uniq <- getUniqueM-                 ; return (LocalReg uniq rep) }--newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])--- Choose suitable local regs to use for the components--- of an unboxed tuple that we are about to return to--- the Sequel.  If the Sequel is a join point, using the--- regs it wants will save later assignments.-newUnboxedTupleRegs res_ty-  = ASSERT( isUnboxedTupleType res_ty )-    do  { dflags <- getDynFlags-        ; sequel <- getSequel-        ; regs <- choose_regs dflags sequel-        ; ASSERT( regs `equalLength` reps )-          return (regs, map primRepForeignHint reps) }-  where-    reps = typePrimRep res_ty-    choose_regs _ (AssignTo regs _) = return regs-    choose_regs dflags _            = mapM (newTemp . primRepCmmType dflags) reps--------------------------------------------------------------------------------      emitMultiAssign----------------------------------------------------------------------------emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()--- Emit code to perform the assignments in the--- input simultaneously, using temporary variables when necessary.--type Key  = Int-type Vrtx = (Key, Stmt) -- Give each vertex a unique number,-                        -- for fast comparison-type Stmt = (LocalReg, CmmExpr) -- r := e---- We use the strongly-connected component algorithm, in which---      * the vertices are the statements---      * an edge goes from s1 to s2 iff---              s1 assigns to something s2 uses---        that is, if s1 should *follow* s2 in the final order--emitMultiAssign []    []    = return ()-emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs-emitMultiAssign regs rhss   = do-  dflags <- getDynFlags-  ASSERT2( equalLength regs rhss, ppr regs $$ ppr rhss )-    unscramble dflags ([1..] `zip` (regs `zip` rhss))--unscramble :: DynFlags -> [Vrtx] -> FCode ()-unscramble dflags vertices = mapM_ do_component components-  where-        edges :: [ Node Key Vrtx ]-        edges = [ DigraphNode vertex key1 (edges_from stmt1)-                | vertex@(key1, stmt1) <- vertices ]--        edges_from :: Stmt -> [Key]-        edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,-                                    stmt1 `mustFollow` stmt2 ]--        components :: [SCC Vrtx]-        components = stronglyConnCompFromEdgedVerticesUniq edges--        -- do_components deal with one strongly-connected component-        -- Not cyclic, or singleton?  Just do it-        do_component :: SCC Vrtx -> FCode ()-        do_component (AcyclicSCC (_,stmt))  = mk_graph stmt-        do_component (CyclicSCC [])         = panic "do_component"-        do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt--                -- Cyclic?  Then go via temporaries.  Pick one to-                -- break the loop and try again with the rest.-        do_component (CyclicSCC ((_,first_stmt) : rest)) = do-            dflags <- getDynFlags-            u <- newUnique-            let (to_tmp, from_tmp) = split dflags u first_stmt-            mk_graph to_tmp-            unscramble dflags rest-            mk_graph from_tmp--        split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt)-        split dflags uniq (reg, rhs)-          = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))-          where-            rep = cmmExprType dflags rhs-            tmp = LocalReg uniq rep--        mk_graph :: Stmt -> FCode ()-        mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs--        mustFollow :: Stmt -> Stmt -> Bool-        (reg, _) `mustFollow` (_, rhs) = regUsedIn dflags (CmmLocal reg) rhs------------------------------------------------------------------------------      mkSwitch-----------------------------------------------------------------------------emitSwitch :: CmmExpr                      -- Tag to switch on-           -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches-           -> Maybe CmmAGraphScoped        -- Default branch (if any)-           -> ConTagZ -> ConTagZ           -- Min and Max possible values;-                                           -- behaviour outside this range is-                                           -- undefined-           -> FCode ()---- First, two rather common cases in which there is no work to do-emitSwitch _ []         (Just code) _ _ = emit (fst code)-emitSwitch _ [(_,code)] Nothing     _ _ = emit (fst code)---- Right, off we go-emitSwitch tag_expr branches mb_deflt lo_tag hi_tag = do-    join_lbl      <- newBlockId-    mb_deflt_lbl  <- label_default join_lbl mb_deflt-    branches_lbls <- label_branches join_lbl branches-    tag_expr'     <- assignTemp' tag_expr--    -- Sort the branches before calling mk_discrete_switch-    let branches_lbls' = [ (fromIntegral i, l) | (i,l) <- sortBy (comparing fst) branches_lbls ]-    let range = (fromIntegral lo_tag, fromIntegral hi_tag)--    emit $ mk_discrete_switch False tag_expr' branches_lbls' mb_deflt_lbl range--    emitLabel join_lbl--mk_discrete_switch :: Bool -- ^ Use signed comparisons-          -> CmmExpr-          -> [(Integer, BlockId)]-          -> Maybe BlockId-          -> (Integer, Integer)-          -> CmmAGraph---- SINGLETON TAG RANGE: no case analysis to do-mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag)-  | lo_tag == hi_tag-  = ASSERT( tag == lo_tag )-    mkBranch lbl---- SINGLETON BRANCH, NO DEFAULT: no case analysis to do-mk_discrete_switch _ _tag_expr [(_tag,lbl)] Nothing _-  = mkBranch lbl-        -- The simplifier might have eliminated a case-        --       so we may have e.g. case xs of-        --                               [] -> e-        -- In that situation we can be sure the (:) case-        -- can't happen, so no need to test---- SOMETHING MORE COMPLICATED: defer to CmmImplementSwitchPlans--- See Note [Cmm Switches, the general plan] in CmmSwitch-mk_discrete_switch signed tag_expr branches mb_deflt range-  = mkSwitch tag_expr $ mkSwitchTargets signed range mb_deflt (M.fromList branches)--divideBranches :: Ord a => [(a,b)] -> ([(a,b)], a, [(a,b)])-divideBranches branches = (lo_branches, mid, hi_branches)-  where-    -- 2 branches => n_branches `div` 2 = 1-    --            => branches !! 1 give the *second* tag-    -- There are always at least 2 branches here-    (mid,_) = branches !! (length branches `div` 2)-    (lo_branches, hi_branches) = span is_lo branches-    is_lo (t,_) = t < mid-----------------emitCmmLitSwitch :: CmmExpr                    -- Tag to switch on-               -> [(Literal, CmmAGraphScoped)] -- Tagged branches-               -> CmmAGraphScoped              -- Default branch (always)-               -> FCode ()                     -- Emit the code-emitCmmLitSwitch _scrut []       deflt = emit $ fst deflt-emitCmmLitSwitch scrut  branches deflt = do-    scrut' <- assignTemp' scrut-    join_lbl <- newBlockId-    deflt_lbl <- label_code join_lbl deflt-    branches_lbls <- label_branches join_lbl branches--    dflags <- getDynFlags-    let cmm_ty = cmmExprType dflags scrut-        rep = typeWidth cmm_ty--    -- We find the necessary type information in the literals in the branches-    let signed = case head branches of-                    (LitNumber nt _ _, _) -> litNumIsSigned nt-                    _ -> False--    let range | signed    = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags)-              | otherwise = (0, tARGET_MAX_WORD dflags)--    if isFloatType cmm_ty-    then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls-    else emit $ mk_discrete_switch-        signed-        scrut'-        [(litValue lit,l) | (lit,l) <- branches_lbls]-        (Just deflt_lbl)-        range-    emitLabel join_lbl---- | lower bound (inclusive), upper bound (exclusive)-type LitBound = (Maybe Literal, Maybe Literal)--noBound :: LitBound-noBound = (Nothing, Nothing)--mk_float_switch :: Width -> CmmExpr -> BlockId-              -> LitBound-              -> [(Literal,BlockId)]-              -> FCode CmmAGraph-mk_float_switch rep scrut deflt _bounds [(lit,blk)]-  = do dflags <- getDynFlags-       return $ mkCbranch (cond dflags) deflt blk Nothing-  where-    cond dflags = CmmMachOp ne [scrut, CmmLit cmm_lit]-      where-        cmm_lit = mkSimpleLit dflags lit-        ne      = MO_F_Ne rep--mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches-  = do dflags <- getDynFlags-       lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches-       hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches-       mkCmmIfThenElse (cond dflags) lo_blk hi_blk-  where-    (lo_branches, mid_lit, hi_branches) = divideBranches branches--    bounds_lo = (lo_bound, Just mid_lit)-    bounds_hi = (Just mid_lit, hi_bound)--    cond dflags = CmmMachOp lt [scrut, CmmLit cmm_lit]-      where-        cmm_lit = mkSimpleLit dflags mid_lit-        lt      = MO_F_Lt rep------------------label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)-label_default _ Nothing-  = return Nothing-label_default join_lbl (Just code)-  = do lbl <- label_code join_lbl code-       return (Just lbl)-----------------label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)]-label_branches _join_lbl []-  = return []-label_branches join_lbl ((tag,code):branches)-  = do lbl <- label_code join_lbl code-       branches' <- label_branches join_lbl branches-       return ((tag,lbl):branches')-----------------label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId---  label_code J code---      generates---  [L: code; goto J]--- and returns L-label_code join_lbl (code,tsc) = do-    lbl <- newBlockId-    emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl, tsc)-    return lbl-----------------assignTemp' :: CmmExpr -> FCode CmmExpr-assignTemp' e-  | isTrivialCmmExpr e = return e-  | otherwise = do-       dflags <- getDynFlags-       lreg <- newTemp (cmmExprType dflags e)-       let reg = CmmLocal lreg-       emitAssign reg e-       return (CmmReg reg)
compiler/coreSyn/CoreLint.hs view
@@ -3,10 +3,12 @@ (c) The GRASP/AQUA Project, Glasgow University, 1993-1998  -A ``lint'' pass to check for Core correctness+A ``lint'' pass to check for Core correctness.+See Note [Core Lint guarantee]. -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}  module CoreLint (     lintCoreBindings, lintUnfolding,@@ -19,7 +21,7 @@     CoreLint.dumpIfSet,  ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -44,10 +46,12 @@ import ErrUtils import Coercion import SrcLoc-import Kind import Type import RepType import TyCoRep       -- checks validity of types/coercions+import TyCoSubst+import TyCoFVs+import TyCoPpr ( pprTyVar ) import TyCon import CoAxiom import BasicTypes@@ -59,7 +63,6 @@ import Util import InstEnv     ( instanceDFunId ) import OptCoercion ( checkAxInstCo )-import UniqSupply import CoreArity ( typeArity ) import Demand ( splitStrictSig, isBotRes ) @@ -75,6 +78,23 @@ import qualified GHC.LanguageExtensions as LangExt  {-+Note [Core Lint guarantee]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Core Lint is the type-checker for Core. Using it, we get the following guarantee:++If all of:+1. Core Lint passes,+2. there are no unsafe coercions (i.e. UnsafeCoerceProv),+3. all plugin-supplied coercions (i.e. PluginProv) are valid, and+4. all case-matches are complete+then running the compiled program will not seg-fault, assuming no bugs downstream+(e.g. in the code generator). This guarantee is quite powerful, in that it allows us+to decouple the safety of the resulting program from the type inference algorithm.++However, do note point (4) above. Core Lint does not check for incomplete case-matches;+see Note [Case expression invariants] in CoreSyn, invariant (4). As explained there,+an incomplete case-match might slip by Core Lint and cause trouble at runtime.+ Note [GHC Formalism] ~~~~~~~~~~~~~~~~~~~~ This file implements the type-checking algorithm for System FC, the "official"@@ -159,7 +179,7 @@  Note [Bad unsafe coercion] ~~~~~~~~~~~~~~~~~~~~~~~~~~-For discussion see https://ghc.haskell.org/trac/ghc/wiki/BadUnsafeCoercions+For discussion see https://gitlab.haskell.org/ghc/ghc/wikis/bad-unsafe-coercions Linter introduces additional rules that checks improper coercion between different types, called bad coercions. Following coercions are forbidden: @@ -373,7 +393,7 @@ -- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty -- so this is a (cheap) no-op. ----- See Trac #8215 for an example+-- See #8215 for an example interactiveInScope hsc_env   = tyvars ++ ids   where@@ -389,6 +409,7 @@               --   f :: [t] -> [t]               -- where t is a RuntimeUnk (see TcType) +-- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc) --   Returns (warnings, errors) -- If you edit this function, you may need to update the GHC formalism@@ -570,15 +591,9 @@               (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder))               -- Only non-rule loop breakers inhibit inlining -      -- Check whether arity and demand type are consistent (only if demand analysis-      -- already happened)-      ---      -- Note (Apr 2014): this is actually ok.  See Note [Demand analysis for trivial right-hand sides]-      --                  in DmdAnal.  After eta-expansion in CorePrep the rhs is no longer trivial.-      --       ; let dmdTy = idStrictness binder-      --       ; checkL (case dmdTy of-      --                  StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs)-      --           (mkArityMsg binder)+       -- We used to check that the dmdTypeDepth of a demand signature never+       -- exceeds idArity, but that is an unnecessary complication, see+       -- Note [idArity varies independently of dmdTypeDepth] in DmdAnal         -- Check that the binder's arity is within the bounds imposed by        -- the type and the strictness signature. See Note [exprArity invariant]@@ -656,7 +671,7 @@         )         -- imitate @lintCoreExpr (App ...)@         (do fun_ty <- lintCoreExpr fun-            addLoc (AnExpr rhs') $ lintCoreArgs fun_ty [Type t, info, e]+            lintCoreArgs fun_ty [Type t, info, e]         )         binders0     go _ = markAllJoinsBad $ lintCoreExpr rhs@@ -776,8 +791,7 @@     (_, dups) = removeDups compare bndrs  lintCoreExpr e@(App _ _)-  = addLoc (AnExpr e) $-    do { fun_ty <- lintCoreFun fun (length args)+  = do { fun_ty <- lintCoreFun fun (length args)        ; lintCoreArgs fun_ty args }   where     (fun, args) = collectArgs e@@ -789,50 +803,8 @@     do { body_ty <- lintCoreExpr expr        ; return $ mkLamType var' body_ty } -lintCoreExpr e@(Case scrut var alt_ty alts) =-       -- Check the scrutinee-  do { scrut_ty <- markAllJoinsBad $ lintCoreExpr scrut-          -- See Note [Join points are less general than the paper]-          -- in CoreSyn--     ; (alt_ty, _) <- lintInTy alt_ty-     ; (var_ty, _) <- lintInTy (idType var)--     -- We used to try to check whether a case expression with no-     -- alternatives was legitimate, but this didn't work.-     -- See Note [No alternatives lint check] for details.--     -- See Note [Rules for floating-point comparisons] in PrelRules-     ; let isLitPat (LitAlt _, _ , _) = True-           isLitPat _                 = False-     ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts)-         (ptext (sLit $ "Lint warning: Scrutinising floating-point " ++-                        "expression with literal pattern in case " ++-                        "analysis (see Trac #9238).")-          $$ text "scrut" <+> ppr scrut)--     ; case tyConAppTyCon_maybe (idType var) of-         Just tycon-              | debugIsOn-              , isAlgTyCon tycon-              , not (isAbstractTyCon tycon)-              , null (tyConDataCons tycon)-              , not (exprIsBottom scrut)-              -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))-                        -- This can legitimately happen for type families-                      $ return ()-         _otherwise -> return ()--        -- Don't use lintIdBndr on var, because unboxed tuple is legitimate--     ; subst <- getTCvSubst-     ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)--     ; lintBinder CaseBind var $ \_ ->-       do { -- Check the alternatives-            mapM_ (lintCoreAlt scrut_ty alt_ty) alts-          ; checkCaseAlts e scrut_ty alts-          ; return alt_ty } }+lintCoreExpr (Case scrut var alt_ty alts)+  = lintCaseExpr scrut var alt_ty alts  -- This case can't happen; linting types in expressions gets routed through -- lintCoreArgs@@ -930,7 +902,7 @@ Note [No alternatives lint check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Case expressions with no alternatives are odd beasts, and it would seem-like they would worth be looking at in the linter (cf Trac #10180). We+like they would worth be looking at in the linter (cf #10180). We used to check two things:  * exprIsHNF is false: it would *seem* to be terribly wrong if@@ -940,7 +912,7 @@   scrutinee is diverging for sure.  It was already known that the second test was not entirely reliable.-Unfortunately (Trac #13990), the first test turned out not to be reliable+Unfortunately (#13990), the first test turned out not to be reliable either. Getting the checks right turns out to be somewhat complicated.  For example, suppose we have (comment 8)@@ -1056,7 +1028,7 @@         ; in_scope <- getInScope         -- substTy needs the set of tyvars in scope to avoid generating         -- uniques that are already in scope.-        -- See Note [The substitution invariant] in TyCoRep+        -- See Note [The substitution invariant] in TyCoSubst         ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) }    | otherwise@@ -1098,6 +1070,60 @@ ************************************************************************ -} +lintCaseExpr :: CoreExpr -> Id -> Type -> [CoreAlt] -> LintM OutType+lintCaseExpr scrut var alt_ty alts =+  do { let e = Case scrut var alt_ty alts   -- Just for error messages++     -- Check the scrutinee+     ; scrut_ty <- markAllJoinsBad $ lintCoreExpr scrut+          -- See Note [Join points are less general than the paper]+          -- in CoreSyn++     ; (alt_ty, _) <- addLoc (CaseTy scrut) $+                      lintInTy alt_ty+     ; (var_ty, _) <- addLoc (IdTy var) $+                      lintInTy (idType var)++     -- We used to try to check whether a case expression with no+     -- alternatives was legitimate, but this didn't work.+     -- See Note [No alternatives lint check] for details.++     -- Check that the scrutinee is not a floating-point type+     -- if there are any literal alternatives+     -- See CoreSyn Note [Case expression invariants] item (5)+     -- See Note [Rules for floating-point comparisons] in PrelRules+     ; let isLitPat (LitAlt _, _ , _) = True+           isLitPat _                 = False+     ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts)+         (ptext (sLit $ "Lint warning: Scrutinising floating-point " +++                        "expression with literal pattern in case " +++                        "analysis (see #9238).")+          $$ text "scrut" <+> ppr scrut)++     ; case tyConAppTyCon_maybe (idType var) of+         Just tycon+              | debugIsOn+              , isAlgTyCon tycon+              , not (isAbstractTyCon tycon)+              , null (tyConDataCons tycon)+              , not (exprIsBottom scrut)+              -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))+                        -- This can legitimately happen for type families+                      $ return ()+         _otherwise -> return ()++        -- Don't use lintIdBndr on var, because unboxed tuple is legitimate++     ; subst <- getTCvSubst+     ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)+       -- See CoreSyn Note [Case expression invariants] item (7)++     ; lintBinder CaseBind var $ \_ ->+       do { -- Check the alternatives+            mapM_ (lintCoreAlt scrut_ty alt_ty) alts+          ; checkCaseAlts e scrut_ty alts+          ; return alt_ty } }+ checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM () -- a) Check that the alts are non-empty -- b1) Check that the DEFAULT comes first, if it exists@@ -1109,7 +1135,10 @@  checkCaseAlts e ty alts =   do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)+         -- See CoreSyn Note [Case expression invariants] item (2)+      ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)+         -- See CoreSyn Note [Case expression invariants] item (3)            -- For types Int#, Word# with an infinite (well, large!) number of           -- possible values, there should usually be a DEFAULT case@@ -1139,6 +1168,7 @@ lintAltExpr expr ann_ty   = do { actual_ty <- lintCoreExpr expr        ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }+         -- See CoreSyn Note [Case expression invariants] item (6)  lintCoreAlt :: OutType          -- Type of scrutinee             -> OutType          -- Type of the alternative@@ -1249,7 +1279,8 @@        ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl)            (mkNonTopExternalNameMsg id) -       ; (ty, k) <- lintInTy (idType id)+       ; (ty, k) <- addLoc (IdTy id) $+                    lintInTy (idType id)            -- See Note [Levity polymorphism invariants] in CoreSyn        ; lintL (isJoinId id || not (isKindLevPoly k))@@ -1352,7 +1383,7 @@  -- arrows can related *unlifted* kinds, so this has to be separate from -- a dependent forall.-lintType ty@(FunTy t1 t2)+lintType ty@(FunTy _ t1 t2)   = do { k1 <- lintType t1        ; k2 <- lintType t2        ; lintArrow (text "type or kind" <+> quotes (ppr ty)) k1 k2 }@@ -1398,7 +1429,7 @@  {- Note [Stupid type synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (Trac #14939)+Consider (#14939)    type Alg cls ob = ob    f :: forall (cls :: * -> Constraint) (b :: Alg cls *). b @@ -1500,7 +1531,7 @@ lint_app doc kfn kas     = do { in_scope <- getInScope          -- We need the in_scope set to satisfy the invariant in-         -- Note [The substitution invariant] in TyCoRep+         -- Note [The substitution invariant] in TyCoSubst          ; foldlM (go_app in_scope) kfn kas }   where     fail_msg extra = vcat [ hang (text "Kind application error in") 2 doc@@ -1512,7 +1543,7 @@       | Just kfn' <- coreView kfn       = go_app in_scope kfn' tka -    go_app _ (FunTy kfa kfb) tka@(_,ka)+    go_app _ (FunTy _ kfa kfb) tka@(_,ka)       = do { unless (ka `eqType` kfa) $              addErrL (fail_msg (text "Fun:" <+> (ppr kfa $$ ppr tka)))            ; return kfb }@@ -1575,18 +1606,18 @@ It's very bad if simplifying a rule means that one of the template variables (ru_bndrs) that /is/ mentioned on the RHS becomes not-mentioned in the LHS (ru_args).  How can that happen?  Well, in-Trac #10602, SpecConstr stupidly constructed a rule like+#10602, SpecConstr stupidly constructed a rule like    forall x,c1,c2.      f (x |> c1 |> c2) = ....  But simplExpr collapses those coercions into one.  (Indeed in-Trac #10602, it collapsed to the identity and was removed altogether.)+#10602, it collapsed to the identity and was removed altogether.)  We don't have a great story for what to do here, but at least this check will nail it. -NB (Trac #11643): it's possible that a variable listed in the+NB (#11643): it's possible that a variable listed in the binders becomes not-mentioned on both LHS and RHS.  Here's a silly example:    RULE forall x y. f (g x y) = g (x+1) (y-1)@@ -1722,7 +1753,7 @@                      -- scope. All the free vars of `t2` and `kind_co` should                      -- already be in `in_scope`, because they've been                      -- linted and `tv2` has the same unique as `tv1`.-                     -- See Note [The substitution invariant]+                     -- See Note [The substitution invariant] in TyCoSubst.                      unitVarEnv tv1 (TyVarTy tv2 `mkCastTy` mkSymCo kind_co)              tyr = mkInvForAllTy tv2 $                    substTy subst t2@@ -1753,7 +1784,7 @@                      -- scope. All the free vars of `t2` and `kind_co` should                      -- already be in `in_scope`, because they've been                      -- linted and `cv2` has the same unique as `cv1`.-                     -- See Note [The substitution invariant]+                     -- See Note [The substitution invariant] in TyCoSubst.                      unitVarEnv cv1 (eta1 `mkTransCo` (mkCoVarCo cv2)                                           `mkTransCo` (mkSymCo eta2))              tyr = mkTyCoInvForAllTy cv2 $@@ -1768,7 +1799,7 @@        ; k' <- lintArrow (text "coercion" <+> quotes (ppr co)) k'1 k'2        ; lintRole co1 r r1        ; lintRole co2 r r2-       ; return (k, k', mkFunTy s1 s2, mkFunTy t1 t2, r) }+       ; return (k, k', mkVisFunTy s1 s2, mkVisFunTy t1 t2, r) }  lintCoercion (CoVarCo cv)   | not (isCoVar cv)@@ -2083,15 +2114,16 @@ newtype LintM a =    LintM { unLintM ::             LintEnv ->-            WarnsAndErrs ->           -- Error and warning messages so far+            WarnsAndErrs ->           -- Warning and error messages so far             (Maybe a, WarnsAndErrs) } -- Result and messages (if any)+   deriving (Functor)  type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc)  {- Note [Checking for global Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Before CoreTidy, all locally-bound Ids must be LocalIds, even-top-level ones. See Note [Exported LocalIds] and Trac #9857.+top-level ones. See Note [Exported LocalIds] and #9857.  Note [Checking StaticPtrs] ~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2127,7 +2159,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When linting a type-synonym, or type-family, application   S ty1 .. tyn-we behave as follows (Trac #15057, #T15664):+we behave as follows (#15057, #T15664):  * If lf_report_unsat_syns = True, and S has arity < n,   complain about an unsaturated type synonym or type family@@ -2155,9 +2187,6 @@   when the type is expanded. -} -instance Functor LintM where-      fmap = liftM- instance Applicative LintM where       pure x = LintM $ \ _ errs -> (Just x, errs)       (<*>) = ap@@ -2185,6 +2214,9 @@   | BodyOfLetRec [Id]   -- One of the binders   | CaseAlt CoreAlt     -- Case alternative   | CasePat CoreAlt     -- The *pattern* of the case alternative+  | CaseTy CoreExpr     -- The type field of a case expression+                        -- with this scrutinee+  | IdTy Id             -- The type field of an Id binder   | AnExpr CoreExpr     -- Some expression   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)   | TopLevelBindings@@ -2192,10 +2224,13 @@   | InCo   Coercion     -- Inside a coercion  initL :: DynFlags -> LintFlags -> InScopeSet-       -> LintM a -> WarnsAndErrs    -- Errors and warnings+       -> LintM a -> WarnsAndErrs    -- Warnings and errors initL dflags flags in_scope m   = case unLintM m env (emptyBag, emptyBag) of-      (_, errs) -> errs+      (Just _, errs) -> errs+      (Nothing, errs@(_, e)) | not (isEmptyBag e) -> errs+                             | otherwise -> pprPanic ("Bug in Lint: a failure occurred " +++                                                      "without reporting an error message") empty   where     env = LE { le_flags = flags              , le_subst = mkEmptyTCvSubst in_scope@@ -2227,30 +2262,39 @@  failWithL :: MsgDoc -> LintM a failWithL msg = LintM $ \ env (warns,errs) ->-                (Nothing, (warns, addMsg env errs msg))+                (Nothing, (warns, addMsg True env errs msg))  addErrL :: MsgDoc -> LintM () addErrL msg = LintM $ \ env (warns,errs) ->-              (Just (), (warns, addMsg env errs msg))+              (Just (), (warns, addMsg True env errs msg))  addWarnL :: MsgDoc -> LintM () addWarnL msg = LintM $ \ env (warns,errs) ->-              (Just (), (addMsg env warns msg, errs))+              (Just (), (addMsg False env warns msg, errs)) -addMsg :: LintEnv ->  Bag MsgDoc -> MsgDoc -> Bag MsgDoc-addMsg env msgs msg-  = ASSERT( notNull locs )+addMsg :: Bool -> LintEnv ->  Bag MsgDoc -> MsgDoc -> Bag MsgDoc+addMsg is_error env msgs msg+  = ASSERT( notNull loc_msgs )     msgs `snocBag` mk_msg msg   where-   locs = le_loc env-   (loc, cxt1) = dumpLoc (head locs)-   cxts        = [snd (dumpLoc loc) | loc <- locs]-   context     = ifPprDebug (vcat (reverse cxts) $$ cxt1 $$-                             text "Substitution:" <+> ppr (le_subst env))-                            cxt1+   loc_msgs :: [(SrcLoc, SDoc)]  -- Innermost first+   loc_msgs = map dumpLoc (le_loc env) -   mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg)+   cxt_doc = vcat [ vcat $ reverse $ map snd loc_msgs+                  , text "Substitution:" <+> ppr (le_subst env) ]+   context | is_error  = cxt_doc+           | otherwise = whenPprDebug cxt_doc+     -- Print voluminous info for Lint errors+     -- but not for warnings +   msg_span = case [ span | (loc,_) <- loc_msgs+                          , let span = srcLocSpan loc+                          , isGoodSrcSpan span ] of+               []    -> noSrcSpan+               (s:_) -> s+   mk_msg msg = mkLocMessage SevWarning msg_span+                             (msg $$ context)+ addLoc :: LintLocInfo -> LintM a -> LintM a addLoc extra_loc m   = LintM $ \ env errs ->@@ -2347,7 +2391,8 @@ lintTyCoVarInScope var   = do { subst <- getTCvSubst        ; lintL (var `isInScope` subst)-               (pprBndr LetBind var <+> text "is out of scope") }+               (hang (text "The variable" <+> pprBndr LetBind var)+                   2 (text "is out of scope")) }  ensureEqTys :: OutType -> OutType -> MsgDoc -> LintM () -- check ty2 is subtype of ty1 (ie, has same structure but usage@@ -2377,19 +2422,19 @@ dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)  dumpLoc (RhsOf v)-  = (getSrcLoc v, brackets (text "RHS of" <+> pp_binders [v]))+  = (getSrcLoc v, text "In the RHS of" <+> pp_binders [v])  dumpLoc (LambdaBodyOf b)-  = (getSrcLoc b, brackets (text "in body of lambda with binder" <+> pp_binder b))+  = (getSrcLoc b, text "In the body of lambda with binder" <+> pp_binder b)  dumpLoc (UnfoldingOf b)-  = (getSrcLoc b, brackets (text "in the unfolding of" <+> pp_binder b))+  = (getSrcLoc b, text "In the unfolding of" <+> pp_binder b)  dumpLoc (BodyOfLetRec [])-  = (noSrcLoc, brackets (text "In body of a letrec with no binders"))+  = (noSrcLoc, text "In body of a letrec with no binders")  dumpLoc (BodyOfLetRec bs@(_:_))-  = ( getSrcLoc (head bs), brackets (text "in body of letrec with binders" <+> pp_binders bs))+  = ( getSrcLoc (head bs), text "In the body of letrec with binders" <+> pp_binders bs)  dumpLoc (AnExpr e)   = (noSrcLoc, text "In the expression:" <+> ppr e)@@ -2400,8 +2445,15 @@ dumpLoc (CasePat (con, args, _))   = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args)) +dumpLoc (CaseTy scrut)+  = (noSrcLoc, hang (text "In the result-type of a case with scrutinee:")+                  2 (ppr scrut))++dumpLoc (IdTy b)+  = (getSrcLoc b, text "In the type of a binder:" <+> ppr b)+ dumpLoc (ImportedUnfolding locn)-  = (locn, brackets (text "in an imported unfolding"))+  = (locn, text "In an imported unfolding") dumpLoc TopLevelBindings   = (noSrcLoc, Outputable.empty) dumpLoc (InType ty)@@ -2562,20 +2614,6 @@           hang (text "Arg type:")                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] -{- Not needed now-mkArityMsg :: Id -> MsgDoc-mkArityMsg binder-  = vcat [hsep [text "Demand type has",-                ppr (dmdTypeDepth dmd_ty),-                text "arguments, rhs has",-                ppr (idArity binder),-                text "arguments,",-                ppr binder],-              hsep [text "Binder's strictness signature:", ppr dmd_ty]--         ]-           where (StrictSig dmd_ty) = idStrictness binder--} mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc mkCastErr expr = mk_cast_err "expression" "type" (ppr expr) @@ -2739,8 +2777,9 @@   dflags <- getDynFlags   let removeFlag env = env{ hsc_dflags = dflags{ debugLevel = 0} }       withoutFlag corem =+          -- TODO: supply tag here as well ?         liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*>-                                getUniqueSupplyM <*> getModule <*>+                                getUniqMask <*> getModule <*>                                 getVisibleOrphanMods <*>                                 getPrintUnqualified <*> getSrcSpanM <*>                                 pure corem
compiler/coreSyn/CorePrep.hs view
@@ -13,7 +13,7 @@       lookupMkNaturalName, lookupNaturalSDataConName   ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -53,9 +53,8 @@ import Util import Pair import Outputable-import Platform+import GHC.Platform import FastString-import Config import Name             ( NamedThing(..), nameSrcSpan ) import SrcLoc           ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) import Data.Bits@@ -179,7 +178,7 @@ corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]             -> IO (CoreProgram, S.Set CostCentre) corePrepPgm hsc_env this_mod mod_loc binds data_tycons =-    withTiming (pure dflags)+    withTiming dflags                (text "CorePrep"<+>brackets (ppr this_mod))                (const ()) $ do     us <- mkSplitUniqSupply 's'@@ -207,7 +206,7 @@  corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr corePrepExpr dflags hsc_env expr =-    withTiming (pure dflags) (text "CorePrep [expr]") (const ()) $ do+    withTiming dflags (text "CorePrep [expr]") (const ()) $ do     us <- mkSplitUniqSupply 's'     initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env     let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)@@ -344,7 +343,7 @@  Note [Dead code in CorePrep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Imagine that we got an input program like this (see Trac #4962):+Imagine that we got an input program like this (see #4962):    f :: Show b => Int -> (Int, b -> Maybe Int -> Int)   f x = (g True (Just x) + g () (Just x), g)@@ -561,6 +560,7 @@ cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr             -> UniqSM (JoinId, CpeRhs) -- Used for all join bindings+-- No eta-expansion: see Note [Do not eta-expand join points] in SimplUtils cpeJoinPair env bndr rhs   = ASSERT(isJoinId bndr)     do { let Just join_arity = isJoinId_maybe bndr@@ -790,7 +790,7 @@ ~~~~~~~~~~~~~~~~~~~ If we got, say    runRW# (case bot of {})-which happened in Trac #11291, we do /not/ want to turn it into+which happened in #11291, we do /not/ want to turn it into    (case bot of {}) realWorldPrimId# because that gives a panic in CoreToStg.myCollectArgs, which expects only variables in function position.  But if we are sure to make@@ -1051,7 +1051,7 @@ Consider    C (let v* = expensive in v)  where the "*" indicates "will be demanded".  Usually v will have been-inlined by now, but let's suppose it hasn't (see Trac #2756).  Then we+inlined by now, but let's suppose it hasn't (see #2756).  Then we do *not* want to get       let v* = expensive in C v@@ -1267,7 +1267,7 @@ wrapBinds (Floats _ binds) body   = foldrOL mk_bind body binds   where-    mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]+    mk_bind (FloatCase bndr rhs _) body = mkDefaultCase rhs bndr body     mk_bind (FloatLet bind)        body = Let bind body     mk_bind (FloatTick tickish)    body = mkTick tickish body
− compiler/deSugar/Check.hs 
@@ -1,2711 +0,0 @@-{--Author: George Karachalias <george.karachalias@cs.kuleuven.be>--Pattern Matching Coverage Checking.--}--{-# LANGUAGE CPP, GADTs, DataKinds, KindSignatures #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns  #-}--module Check (-        -- Checking and printing-        checkSingle, checkMatches, checkGuardMatches, isAnyPmCheckEnabled,--        -- See Note [Type and Term Equality Propagation]-        genCaseTmCs1, genCaseTmCs2-    ) where--#include "GhclibHsVersions.h"--import GhcPrelude--import TmOracle-import Unify( tcMatchTy )-import DynFlags-import HsSyn-import TcHsSyn-import Id-import ConLike-import Name-import FamInstEnv-import TysPrim (tYPETyCon)-import TysWiredIn-import TyCon-import SrcLoc-import Util-import Outputable-import FastString-import DataCon-import PatSyn-import HscTypes (CompleteMatch(..))-import BasicTypes (Boxity(..))--import DsMonad-import TcSimplify    (tcCheckSatisfiability)-import TcType        (isStringTy)-import Bag-import ErrUtils-import Var           (EvVar)-import TyCoRep-import Type-import UniqSupply-import DsUtils       (isTrueLHsExpr)-import qualified GHC.LanguageExtensions as LangExt--import Data.List     (find)-import Data.Maybe    (catMaybes, isJust, fromMaybe)-import Control.Monad (forM, when, forM_, zipWithM)-import Coercion-import TcEvidence-import TcSimplify    (tcNormalise)-import IOEnv-import qualified Data.Semigroup as Semi--import ListT (ListT(..), fold, select)--{--This module checks pattern matches for:-\begin{enumerate}-  \item Equations that are redundant-  \item Equations with inaccessible right-hand-side-  \item Exhaustiveness-\end{enumerate}--The algorithm is based on the paper:--  "GADTs Meet Their Match:-     Pattern-matching Warnings That Account for GADTs, Guards, and Laziness"--    http://people.cs.kuleuven.be/~george.karachalias/papers/p424-karachalias.pdf--%************************************************************************-%*                                                                      *-                     Pattern Match Check Types-%*                                                                      *-%************************************************************************--}---- We use the non-determinism monad to apply the algorithm to several--- possible sets of constructors. Users can specify complete sets of--- constructors by using COMPLETE pragmas.--- The algorithm only picks out constructor--- sets deep in the bowels which makes a simpler `mapM` more difficult to--- implement. The non-determinism is only used in one place, see the ConVar--- case in `pmCheckHd`.--type PmM a = ListT DsM a--liftD :: DsM a -> PmM a-liftD m = ListT $ \sk fk -> m >>= \a -> sk a fk---- Pick the first match complete covered match or otherwise the "best" match.--- The best match is the one with the least uncovered clauses, ties broken--- by the number of inaccessible clauses followed by number of redundant--- clauses.------ This is specified in the--- "Disambiguating between multiple ``COMPLETE`` pragmas" section of the--- users' guide. If you update the implementation of this function, make sure--- to update that section of the users' guide as well.-getResult :: PmM PmResult -> DsM PmResult-getResult ls-  = do { res <- fold ls goM (pure Nothing)-       ; case res of-            Nothing -> panic "getResult is empty"-            Just a  -> return a }-  where-    goM :: PmResult -> DsM (Maybe PmResult) -> DsM (Maybe PmResult)-    goM mpm dpm = do { pmr <- dpm-                     ; return $ Just $ go pmr mpm }--    -- Careful not to force unecessary results-    go :: Maybe PmResult -> PmResult -> PmResult-    go Nothing rs = rs-    go (Just old@(PmResult prov rs (UncoveredPatterns us) is)) new-      | null us && null rs && null is = old-      | otherwise =-        let PmResult prov' rs' (UncoveredPatterns us') is' = new-        in case compareLength us us'-                `mappend` (compareLength is is')-                `mappend` (compareLength rs rs')-                `mappend` (compare prov prov') of-              GT  -> new-              EQ  -> new-              LT  -> old-    go (Just (PmResult _ _ (TypeOfUncovered _) _)) _new-      = panic "getResult: No inhabitation candidates"--data PatTy = PAT | VA -- Used only as a kind, to index PmPat---- The *arity* of a PatVec [p1,..,pn] is--- the number of p1..pn that are not Guards--data PmPat :: PatTy -> * where-  PmCon  :: { pm_con_con     :: ConLike-            , pm_con_arg_tys :: [Type]-            , pm_con_tvs     :: [TyVar]-            , pm_con_dicts   :: [EvVar]-            , pm_con_args    :: [PmPat t] } -> PmPat t-            -- For PmCon arguments' meaning see @ConPatOut@ in hsSyn/HsPat.hs-  PmVar  :: { pm_var_id   :: Id } -> PmPat t-  PmLit  :: { pm_lit_lit  :: PmLit } -> PmPat t -- See Note [Literals in PmPat]-  PmNLit :: { pm_lit_id   :: Id-            , pm_lit_not  :: [PmLit] } -> PmPat 'VA-  PmGrd  :: { pm_grd_pv   :: PatVec-            , pm_grd_expr :: PmExpr  } -> PmPat 'PAT--instance Outputable (PmPat a) where-  ppr = pprPmPatDebug---- data T a where---     MkT :: forall p q. (Eq p, Ord q) => p -> q -> T [p]--- or  MkT :: forall p q r. (Eq p, Ord q, [p] ~ r) => p -> q -> T r--type Pattern = PmPat 'PAT -- ^ Patterns-type ValAbs  = PmPat 'VA  -- ^ Value Abstractions--type PatVec = [Pattern]             -- ^ Pattern Vectors-data ValVec = ValVec [ValAbs] Delta -- ^ Value Vector Abstractions---- | Term and type constraints to accompany each value vector abstraction.--- For efficiency, we store the term oracle state instead of the term--- constraints. TODO: Do the same for the type constraints?-data Delta = MkDelta { delta_ty_cs :: Bag EvVar-                     , delta_tm_cs :: TmState }--type ValSetAbs = [ValVec]  -- ^ Value Set Abstractions-type Uncovered = ValSetAbs---- Instead of keeping the whole sets in memory, we keep a boolean for both the--- covered and the divergent set (we store the uncovered set though, since we--- want to print it). For both the covered and the divergent we have:------   True <=> The set is non-empty------ hence:---  C = True             ==> Useful clause (no warning)---  C = False, D = True  ==> Clause with inaccessible RHS---  C = False, D = False ==> Redundant clause--data Covered = Covered | NotCovered-  deriving Show--instance Outputable Covered where-  ppr (Covered) = text "Covered"-  ppr (NotCovered) = text "NotCovered"---- Like the or monoid for booleans--- Covered = True, Uncovered = False-instance Semi.Semigroup Covered where-  Covered <> _ = Covered-  _ <> Covered = Covered-  NotCovered <> NotCovered = NotCovered--instance Monoid Covered where-  mempty = NotCovered-  mappend = (Semi.<>)--data Diverged = Diverged | NotDiverged-  deriving Show--instance Outputable Diverged where-  ppr Diverged = text "Diverged"-  ppr NotDiverged = text "NotDiverged"--instance Semi.Semigroup Diverged where-  Diverged <> _ = Diverged-  _ <> Diverged = Diverged-  NotDiverged <> NotDiverged = NotDiverged--instance Monoid Diverged where-  mempty = NotDiverged-  mappend = (Semi.<>)---- | When we learned that a given match group is complete-data Provenance =-                  FromBuiltin -- ^  From the original definition of the type-                              --    constructor.-                | FromComplete -- ^ From a user-provided @COMPLETE@ pragma-  deriving (Show, Eq, Ord)--instance Outputable Provenance where-  ppr  = text . show--instance Semi.Semigroup Provenance where-  FromComplete <> _ = FromComplete-  _ <> FromComplete = FromComplete-  _ <> _ = FromBuiltin--instance Monoid Provenance where-  mempty = FromBuiltin-  mappend = (Semi.<>)--data PartialResult = PartialResult {-                        presultProvenance :: Provenance-                         -- keep track of provenance because we don't want-                         -- to warn about redundant matches if the result-                         -- is contaminated with a COMPLETE pragma-                      , presultCovered :: Covered-                      , presultUncovered :: Uncovered-                      , presultDivergent :: Diverged }--instance Outputable PartialResult where-  ppr (PartialResult prov c vsa d)-           = text "PartialResult" <+> ppr prov <+> ppr c-                                  <+> ppr d <+> ppr vsa---instance Semi.Semigroup PartialResult where-  (PartialResult prov1 cs1 vsa1 ds1)-    <> (PartialResult prov2 cs2 vsa2 ds2)-      = PartialResult (prov1 Semi.<> prov2)-                      (cs1 Semi.<> cs2)-                      (vsa1 Semi.<> vsa2)-                      (ds1 Semi.<> ds2)---instance Monoid PartialResult where-  mempty = PartialResult mempty mempty [] mempty-  mappend = (Semi.<>)---- newtype ChoiceOf a = ChoiceOf [a]---- | Pattern check result------ * Redundant clauses--- * Not-covered clauses (or their type, if no pattern is available)--- * Clauses with inaccessible RHS------ More details about the classification of clauses into useful, redundant--- and with inaccessible right hand side can be found here:------     https://ghc.haskell.org/trac/ghc/wiki/PatternMatchCheck----data PmResult =-  PmResult {-      pmresultProvenance   :: Provenance-    , pmresultRedundant    :: [Located [LPat GhcTc]]-    , pmresultUncovered    :: UncoveredCandidates-    , pmresultInaccessible :: [Located [LPat GhcTc]] }---- | Either a list of patterns that are not covered, or their type, in case we--- have no patterns at hand. Not having patterns at hand can arise when--- handling EmptyCase expressions, in two cases:------ * The type of the scrutinee is a trivially inhabited type (like Int or Char)--- * The type of the scrutinee cannot be reduced to WHNF.------ In both these cases we have no inhabitation candidates for the type at hand,--- but we don't want to issue just a wildcard as missing. Instead, we print a--- type annotated wildcard, so that the user knows what kind of patterns is--- expected (e.g. (_ :: Int), or (_ :: F Int), where F Int does not reduce).-data UncoveredCandidates = UncoveredPatterns Uncovered-                         | TypeOfUncovered Type---- | The empty pattern check result-emptyPmResult :: PmResult-emptyPmResult = PmResult FromBuiltin [] (UncoveredPatterns []) []---- | Non-exhaustive empty case with unknown/trivial inhabitants-uncoveredWithTy :: Type -> PmResult-uncoveredWithTy ty = PmResult FromBuiltin [] (TypeOfUncovered ty) []--{--%************************************************************************-%*                                                                      *-       Entry points to the checker: checkSingle and checkMatches-%*                                                                      *-%************************************************************************--}---- | Check a single pattern binding (let)-checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat GhcTc -> DsM ()-checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do-  tracePmD "checkSingle" (vcat [ppr ctxt, ppr var, ppr p])-  mb_pm_res <- tryM (getResult (checkSingle' locn var p))-  case mb_pm_res of-    Left  _   -> warnPmIters dflags ctxt-    Right res -> dsPmWarn dflags ctxt res---- | Check a single pattern binding (let)-checkSingle' :: SrcSpan -> Id -> Pat GhcTc -> PmM PmResult-checkSingle' locn var p = do-  liftD resetPmIterDs -- set the iter-no to zero-  fam_insts <- liftD dsGetFamInstEnvs-  clause    <- liftD $ translatePat fam_insts p-  missing   <- mkInitialUncovered [var]-  tracePm "checkSingle: missing" (vcat (map pprValVecDebug missing))-                                 -- no guards-  PartialResult prov cs us ds <- runMany (pmcheckI clause []) missing-  let us' = UncoveredPatterns us-  return $ case (cs,ds) of-    (Covered,  _    )         -> PmResult prov [] us' [] -- useful-    (NotCovered, NotDiverged) -> PmResult prov m  us' [] -- redundant-    (NotCovered, Diverged )   -> PmResult prov [] us' m  -- inaccessible rhs-  where m = [cL locn [cL locn p]]---- | Exhaustive for guard matches, is used for guards in pattern bindings and--- in @MultiIf@ expressions.-checkGuardMatches :: HsMatchContext Name          -- Match context-                  -> GRHSs GhcTc (LHsExpr GhcTc)  -- Guarded RHSs-                  -> DsM ()-checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do-    dflags <- getDynFlags-    let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss)-        dsMatchContext = DsMatchContext hs_ctx combinedLoc-        match = cL combinedLoc $-                  Match { m_ext = noExt-                        , m_ctxt = hs_ctx-                        , m_pats = []-                        , m_grhss = guards }-    checkMatches dflags dsMatchContext [] [match]-checkGuardMatches _ (XGRHSs _) = panic "checkGuardMatches"---- | Check a matchgroup (case, functions, etc.)-checkMatches :: DynFlags -> DsMatchContext-             -> [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM ()-checkMatches dflags ctxt vars matches = do-  tracePmD "checkMatches" (hang (vcat [ppr ctxt-                               , ppr vars-                               , text "Matches:"])-                               2-                               (vcat (map ppr matches)))-  mb_pm_res <- tryM $ getResult $ case matches of-    -- Check EmptyCase separately-    -- See Note [Checking EmptyCase Expressions]-    [] | [var] <- vars -> checkEmptyCase' var-    _normal_match      -> checkMatches' vars matches-  case mb_pm_res of-    Left  _   -> warnPmIters dflags ctxt-    Right res -> dsPmWarn dflags ctxt res---- | Check a matchgroup (case, functions, etc.). To be called on a non-empty--- list of matches. For empty case expressions, use checkEmptyCase' instead.-checkMatches' :: [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> PmM PmResult-checkMatches' vars matches-  | null matches = panic "checkMatches': EmptyCase"-  | otherwise = do-      liftD resetPmIterDs -- set the iter-no to zero-      missing    <- mkInitialUncovered vars-      tracePm "checkMatches': missing" (vcat (map pprValVecDebug missing))-      (prov, rs,us,ds) <- go matches missing-      return $ PmResult {-                   pmresultProvenance   = prov-                 , pmresultRedundant    = map hsLMatchToLPats rs-                 , pmresultUncovered    = UncoveredPatterns us-                 , pmresultInaccessible = map hsLMatchToLPats ds }-  where-    go :: [LMatch GhcTc (LHsExpr GhcTc)] -> Uncovered-       -> PmM (Provenance-              , [LMatch GhcTc (LHsExpr GhcTc)]-              , Uncovered-              , [LMatch GhcTc (LHsExpr GhcTc)])-    go []     missing = return (mempty, [], missing, [])-    go (m:ms) missing = do-      tracePm "checMatches': go" (ppr m $$ ppr missing)-      fam_insts          <- liftD dsGetFamInstEnvs-      (clause, guards)   <- liftD $ translateMatch fam_insts m-      r@(PartialResult prov cs missing' ds)-        <- runMany (pmcheckI clause guards) missing-      tracePm "checMatches': go: res" (ppr r)-      (ms_prov, rs, final_u, is)  <- go ms missing'-      let final_prov = prov `mappend` ms_prov-      return $ case (cs, ds) of-        -- useful-        (Covered,  _    )        -> (final_prov,  rs, final_u,   is)-        -- redundant-        (NotCovered, NotDiverged) -> (final_prov, m:rs, final_u,is)-        -- inaccessible-        (NotCovered, Diverged )   -> (final_prov,  rs, final_u, m:is)--    hsLMatchToLPats :: LMatch id body -> Located [LPat id]-    hsLMatchToLPats (dL->L l (Match { m_pats = pats })) = cL l pats-    hsLMatchToLPats _                                   = panic "checMatches'"---- | Check an empty case expression. Since there are no clauses to process, we---   only compute the uncovered set. See Note [Checking EmptyCase Expressions]---   for details.-checkEmptyCase' :: Id -> PmM PmResult-checkEmptyCase' var = do-  tm_ty_css     <- pmInitialTmTyCs-  mb_candidates <- inhabitationCandidates (delta_ty_cs tm_ty_css) (idType var)-  case mb_candidates of-    -- Inhabitation checking failed / the type is trivially inhabited-    Left ty -> return (uncoveredWithTy ty)--    -- A list of inhabitant candidates is available: Check for each-    -- one for the satisfiability of the constraints it gives rise to.-    Right (_, candidates) -> do-      missing_m <- flip mapMaybeM candidates $-          \InhabitationCandidate{ ic_val_abs = va, ic_tm_ct = tm_ct-                                , ic_ty_cs = ty_cs-                                , ic_strict_arg_tys = strict_arg_tys } -> do-        mb_sat <- pmIsSatisfiable tm_ty_css tm_ct ty_cs strict_arg_tys-        pure $ fmap (ValVec [va]) mb_sat-      return $ if null missing_m-        then emptyPmResult-        else PmResult FromBuiltin [] (UncoveredPatterns missing_m) []---- | Returns 'True' if the argument 'Type' is a fully saturated application of--- a closed type constructor.------ Closed type constructors are those with a fixed right hand side, as--- opposed to e.g. associated types. These are of particular interest for--- pattern-match coverage checking, because GHC can exhaustively consider all--- possible forms that values of a closed type can take on.------ Note that this function is intended to be used to check types of value-level--- patterns, so as a consequence, the 'Type' supplied as an argument to this--- function should be of kind @Type@.-pmIsClosedType :: Type -> Bool-pmIsClosedType ty-  = case splitTyConApp_maybe ty of-      Just (tc, ty_args)-             | is_algebraic_like tc && not (isFamilyTyCon tc)-             -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True-      _other -> False-  where-    -- This returns True for TyCons which /act like/ algebraic types.-    -- (See "Type#type_classification" for what an algebraic type is.)-    ---    -- This is qualified with \"like\" because of a particular special-    -- case: TYPE (the underlyind kind behind Type, among others). TYPE-    -- is conceptually a datatype (and thus algebraic), but in practice it is-    -- a primitive builtin type, so we must check for it specially.-    ---    -- NB: it makes sense to think of TYPE as a closed type in a value-level,-    -- pattern-matching context. However, at the kind level, TYPE is certainly-    -- not closed! Since this function is specifically tailored towards pattern-    -- matching, however, it's OK to label TYPE as closed.-    is_algebraic_like :: TyCon -> Bool-    is_algebraic_like tc = isAlgTyCon tc || tc == tYPETyCon--pmTopNormaliseType_maybe :: FamInstEnvs -> Bag EvVar -> Type-                         -> PmM (Maybe (Type, [DataCon], Type))--- ^ Get rid of *outermost* (or toplevel)---      * type function redex---      * data family redex---      * newtypes------ Behaves exactly like `topNormaliseType_maybe`, but instead of returning a--- coercion, it returns useful information for issuing pattern matching--- warnings. See Note [Type normalisation for EmptyCase] for details.------ NB: Normalisation can potentially change kinds, if the head of the type--- is a type family with a variable result kind. I (Richard E) can't think--- of a way to cause trouble here, though.-pmTopNormaliseType_maybe env ty_cs typ-  = do (_, mb_typ') <- liftD $ initTcDsForSolver $ tcNormalise ty_cs typ-         -- Before proceeding, we chuck typ into the constraint solver, in case-         -- solving for given equalities may reduce typ some. See-         -- "Wrinkle: local equalities" in-         -- Note [Type normalisation for EmptyCase].-       pure $ do typ' <- mb_typ'-                 ((ty_f,tm_f), ty) <- topNormaliseTypeX stepper comb typ'-                 -- We need to do topNormaliseTypeX in addition to tcNormalise,-                 -- since topNormaliseX looks through newtypes, which-                 -- tcNormalise does not do.-                 Just (eq_src_ty ty (typ' : ty_f [ty]), tm_f [], ty)-  where-    -- Find the first type in the sequence of rewrites that is a data type,-    -- newtype, or a data family application (not the representation tycon!).-    -- This is the one that is equal (in source Haskell) to the initial type.-    -- If none is found in the list, then all of them are type family-    -- applications, so we simply return the last one, which is the *simplest*.-    eq_src_ty :: Type -> [Type] -> Type-    eq_src_ty ty tys = maybe ty id (find is_closed_or_data_family tys)--    is_closed_or_data_family :: Type -> Bool-    is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyAppType ty--    -- For efficiency, represent both lists as difference lists.-    -- comb performs the concatenation, for both lists.-    comb (tyf1, tmf1) (tyf2, tmf2) = (tyf1 . tyf2, tmf1 . tmf2)--    stepper = newTypeStepper `composeSteppers` tyFamStepper--    -- A 'NormaliseStepper' that unwraps newtypes, careful not to fall into-    -- a loop. If it would fall into a loop, it produces 'NS_Abort'.-    newTypeStepper :: NormaliseStepper ([Type] -> [Type],[DataCon] -> [DataCon])-    newTypeStepper rec_nts tc tys-      | Just (ty', _co) <- instNewTyCon_maybe tc tys-      = case checkRecTc rec_nts tc of-          Just rec_nts' -> let tyf = ((TyConApp tc tys):)-                               tmf = ((tyConSingleDataCon tc):)-                           in  NS_Step rec_nts' ty' (tyf, tmf)-          Nothing       -> NS_Abort-      | otherwise-      = NS_Done--    tyFamStepper :: NormaliseStepper ([Type] -> [Type], [DataCon] -> [DataCon])-    tyFamStepper rec_nts tc tys  -- Try to step a type/data family-      = let (_args_co, ntys, _res_co) = normaliseTcArgs env Representational tc tys in-          -- NB: It's OK to use normaliseTcArgs here instead of-          -- normalise_tc_args (which takes the LiftingContext described-          -- in Note [Normalising types]) because the reduceTyFamApp below-          -- works only at top level. We'll never recur in this function-          -- after reducing the kind of a bound tyvar.--        case reduceTyFamApp_maybe env Representational tc ntys of-          Just (_co, rhs) -> NS_Step rec_nts rhs ((rhs:), id)-          _               -> NS_Done---- | Determine suitable constraints to use at the beginning of pattern-match--- coverage checking by consulting the sets of term and type constraints--- currently in scope. If one of these sets of constraints is unsatisfiable,--- use an empty set in its place. (See--- @Note [Recovering from unsatisfiable pattern-matching constraints]@--- for why this is done.)-pmInitialTmTyCs :: PmM Delta-pmInitialTmTyCs = do-  ty_cs  <- liftD getDictsDs-  tm_cs  <- map toComplex . bagToList <$> liftD getTmCsDs-  sat_ty <- tyOracle ty_cs-  let initTyCs = if sat_ty then ty_cs else emptyBag-      initTmState = fromMaybe initialTmState (tmOracle initialTmState tm_cs)-  pure $ MkDelta{ delta_tm_cs = initTmState, delta_ty_cs = initTyCs }--{--Note [Recovering from unsatisfiable pattern-matching constraints]-~~~~~~~~~~~~~~~~-Consider the following code (see #12957 and #15450):--  f :: Int ~ Bool => ()-  f = case True of { False -> () }--We want to warn that the pattern-matching in `f` is non-exhaustive. But GHC-used not to do this; in fact, it would warn that the match was /redundant/!-This is because the constraint (Int ~ Bool) in `f` is unsatisfiable, and the-coverage checker deems any matches with unsatifiable constraint sets to be-unreachable.--We decide to better than this. When beginning coverage checking, we first-check if the constraints in scope are unsatisfiable, and if so, we start-afresh with an empty set of constraints. This way, we'll get the warnings-that we expect.--}---- | Given a conlike's term constraints, type constraints, and strict argument--- types, check if they are satisfiable.--- (In other words, this is the ⊢_Sat oracle judgment from the GADTs Meet--- Their Match paper.)------ For the purposes of efficiency, this takes as separate arguments the--- ambient term and type constraints (which are known beforehand to be--- satisfiable), as well as the new term and type constraints (which may not--- be satisfiable). This lets us implement two mini-optimizations:------ * If there are no new type constraints, then don't bother initializing---   the type oracle, since it's redundant to do so.--- * Since the new term constraint is a separate argument, we only need to---   execute one iteration of the term oracle (instead of traversing the---   entire set of term constraints).------ Taking strict argument types into account is something which was not--- discussed in GADTs Meet Their Match. For an explanation of what role they--- serve, see @Note [Extensions to GADTs Meet Their Match]@.-pmIsSatisfiable-  :: Delta     -- ^ The ambient term and type constraints-               --   (known to be satisfiable).-  -> ComplexEq -- ^ The new term constraint.-  -> Bag EvVar -- ^ The new type constraints.-  -> [Type]    -- ^ The strict argument types.-  -> PmM (Maybe Delta)-               -- ^ @'Just' delta@ if the constraints (@delta@) are-               -- satisfiable, and each strict argument type is inhabitable.-               -- 'Nothing' otherwise.-pmIsSatisfiable amb_cs new_tm_c new_ty_cs strict_arg_tys = do-  mb_sat <- tmTyCsAreSatisfiable amb_cs new_tm_c new_ty_cs-  case mb_sat of-    Nothing -> pure Nothing-    Just delta -> do-      -- We know that the term and type constraints are inhabitable, so now-      -- check if each strict argument type is inhabitable.-      all_non_void <- checkAllNonVoid initRecTc delta strict_arg_tys-      pure $ if all_non_void -- Check if each strict argument type-                             -- is inhabitable-                then Just delta-                else Nothing---- | Like 'pmIsSatisfiable', but only checks if term and type constraints are--- satisfiable, and doesn't bother checking anything related to strict argument--- types.-tmTyCsAreSatisfiable-  :: Delta     -- ^ The ambient term and type constraints-               --   (known to be satisfiable).-  -> ComplexEq -- ^ The new term constraint.-  -> Bag EvVar -- ^ The new type constraints.-  -> PmM (Maybe Delta)-       -- ^ @'Just' delta@ if the constraints (@delta@) are-       -- satisfiable. 'Nothing' otherwise.-tmTyCsAreSatisfiable-    (MkDelta{ delta_tm_cs = amb_tm_cs, delta_ty_cs = amb_ty_cs })-    new_tm_c new_ty_cs = do-  let ty_cs = new_ty_cs `unionBags` amb_ty_cs-  sat_ty <- if isEmptyBag new_ty_cs-               then pure True-               else tyOracle ty_cs-  pure $ case (sat_ty, solveOneEq amb_tm_cs new_tm_c) of-           (True, Just term_cs) -> Just $ MkDelta{ delta_ty_cs = ty_cs-                                                 , delta_tm_cs = term_cs }-           _unsat               -> Nothing---- | Implements two performance optimizations, as described in the--- \"Strict argument type constraints\" section of--- @Note [Extensions to GADTs Meet Their Match]@.-checkAllNonVoid :: RecTcChecker -> Delta -> [Type] -> PmM Bool-checkAllNonVoid rec_ts amb_cs strict_arg_tys = do-  fam_insts <- liftD dsGetFamInstEnvs-  let definitely_inhabited =-        definitelyInhabitedType fam_insts (delta_ty_cs amb_cs)-  tys_to_check <- filterOutM definitely_inhabited strict_arg_tys-  let rec_max_bound | tys_to_check `lengthExceeds` 1-                    = 1-                    | otherwise-                    = defaultRecTcMaxBound-      rec_ts' = setRecTcMaxBound rec_max_bound rec_ts-  allM (nonVoid rec_ts' amb_cs) tys_to_check---- | Checks if a strict argument type of a conlike is inhabitable by a--- terminating value (i.e, an 'InhabitationCandidate').--- See @Note [Extensions to GADTs Meet Their Match]@.-nonVoid-  :: RecTcChecker -- ^ The per-'TyCon' recursion depth limit.-  -> Delta        -- ^ The ambient term/type constraints (known to be-                  --   satisfiable).-  -> Type         -- ^ The strict argument type.-  -> PmM Bool     -- ^ 'True' if the strict argument type might be inhabited by-                  --   a terminating value (i.e., an 'InhabitationCandidate').-                  --   'False' if it is definitely uninhabitable by anything-                  --   (except bottom).-nonVoid rec_ts amb_cs strict_arg_ty = do-  mb_cands <- inhabitationCandidates (delta_ty_cs amb_cs) strict_arg_ty-  case mb_cands of-    Right (tc, cands)-      |  Just rec_ts' <- checkRecTc rec_ts tc-      -> anyM (cand_is_inhabitable rec_ts' amb_cs) cands-           -- A strict argument type is inhabitable by a terminating value if-           -- at least one InhabitationCandidate is inhabitable.-    _ -> pure True-           -- Either the type is trivially inhabited or we have exceeded the-           -- recursion depth for some TyCon (so bail out and conservatively-           -- claim the type is inhabited).-  where-    -- Checks if an InhabitationCandidate for a strict argument type:-    ---    -- (1) Has satisfiable term and type constraints.-    -- (2) Has 'nonVoid' strict argument types (we bail out of this-    --     check if recursion is detected).-    ---    -- See Note [Extensions to GADTs Meet Their Match]-    cand_is_inhabitable :: RecTcChecker -> Delta-                        -> InhabitationCandidate -> PmM Bool-    cand_is_inhabitable rec_ts amb_cs-      (InhabitationCandidate{ ic_tm_ct          = new_term_c-                            , ic_ty_cs          = new_ty_cs-                            , ic_strict_arg_tys = new_strict_arg_tys }) = do-        mb_sat <- tmTyCsAreSatisfiable amb_cs new_term_c new_ty_cs-        case mb_sat of-          Nothing -> pure False-          Just new_delta -> do-            checkAllNonVoid rec_ts new_delta new_strict_arg_tys---- | @'definitelyInhabitedType' ty@ returns 'True' if @ty@ has at least one--- constructor @C@ such that:------ 1. @C@ has no equality constraints.--- 2. @C@ has no strict argument types.------ See the \"Strict argument type constraints\" section of--- @Note [Extensions to GADTs Meet Their Match]@.-definitelyInhabitedType :: FamInstEnvs -> Bag EvVar -> Type -> PmM Bool-definitelyInhabitedType env ty_cs ty = do-  mb_res <- pmTopNormaliseType_maybe env ty_cs ty-  pure $ case mb_res of-           Just (_, cons, _) -> any meets_criteria cons-           Nothing           -> False-  where-    meets_criteria :: DataCon -> Bool-    meets_criteria con =-      null (dataConEqSpec con) && -- (1)-      null (dataConImplBangs con) -- (2)--{- Note [Type normalisation for EmptyCase]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-EmptyCase is an exception for pattern matching, since it is strict. This means-that it boils down to checking whether the type of the scrutinee is inhabited.-Function pmTopNormaliseType_maybe gets rid of the outermost type function/data-family redex and newtypes, in search of an algebraic type constructor, which is-easier to check for inhabitation.--It returns 3 results instead of one, because there are 2 subtle points:-1. Newtypes are isomorphic to the underlying type in core but not in the source-   language,-2. The representational data family tycon is used internally but should not be-   shown to the user--Hence, if pmTopNormaliseType_maybe env ty_cs ty = Just (src_ty, dcs, core_ty),-then-  (a) src_ty is the rewritten type which we can show to the user. That is, the-      type we get if we rewrite type families but not data families or-      newtypes.-  (b) dcs is the list of data constructors "skipped", every time we normalise a-      newtype to its core representation, we keep track of the source data-      constructor.-  (c) core_ty is the rewritten type. That is,-        pmTopNormaliseType_maybe env ty_cs ty = Just (src_ty, dcs, core_ty)-      implies-        topNormaliseType_maybe env ty = Just (co, core_ty)-      for some coercion co.--To see how all cases come into play, consider the following example:--  data family T a :: *-  data instance T Int = T1 | T2 Bool-  -- Which gives rise to FC:-  --   data T a-  --   data R:TInt = T1 | T2 Bool-  --   axiom ax_ti : T Int ~R R:TInt--  newtype G1 = MkG1 (T Int)-  newtype G2 = MkG2 G1--  type instance F Int  = F Char-  type instance F Char = G2--In this case pmTopNormaliseType_maybe env ty_cs (F Int) results in--  Just (G2, [MkG2,MkG1], R:TInt)--Which means that in source Haskell:-  - G2 is equivalent to F Int (in contrast, G1 isn't).-  - if (x : R:TInt) then (MkG2 (MkG1 x) : F Int).---------- Wrinkle: Local equalities--------Given the following type family:--  type family F a-  type instance F Int = Void--Should the following program (from #14813) be considered exhaustive?--  f :: (i ~ Int) => F i -> a-  f x = case x of {}--You might think "of course, since `x` is obviously of type Void". But the-idType of `x` is technically F i, not Void, so if we pass F i to-inhabitationCandidates, we'll mistakenly conclude that `f` is non-exhaustive.-In order to avoid this pitfall, we need to normalise the type passed to-pmTopNormaliseType_maybe, using the constraint solver to solve for any local-equalities (such as i ~ Int) that may be in scope.--}---- | Generate all 'InhabitationCandidate's for a given type. The result is--- either @'Left' ty@, if the type cannot be reduced to a closed algebraic type--- (or if it's one trivially inhabited, like 'Int'), or @'Right' candidates@,--- if it can. In this case, the candidates are the signature of the tycon, each--- one accompanied by the term- and type- constraints it gives rise to.--- See also Note [Checking EmptyCase Expressions]-inhabitationCandidates :: Bag EvVar -> Type-                       -> PmM (Either Type (TyCon, [InhabitationCandidate]))-inhabitationCandidates ty_cs ty = do-  fam_insts   <- liftD dsGetFamInstEnvs-  mb_norm_res <- pmTopNormaliseType_maybe fam_insts ty_cs ty-  case mb_norm_res of-    Just (src_ty, dcs, core_ty) -> alts_to_check src_ty core_ty dcs-    Nothing                     -> alts_to_check ty     ty      []-  where-    -- All these types are trivially inhabited-    trivially_inhabited = [ charTyCon, doubleTyCon, floatTyCon-                          , intTyCon, wordTyCon, word8TyCon ]--    -- Note: At the moment we leave all the typing and constraint fields of-    -- PmCon empty, since we know that they are not gonna be used. Is the-    -- right-thing-to-do to actually create them, even if they are never used?-    build_tm :: ValAbs -> [DataCon] -> ValAbs-    build_tm = foldr (\dc e -> PmCon (RealDataCon dc) [] [] [] [e])--    -- Inhabitation candidates, using the result of pmTopNormaliseType_maybe-    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, tc_args)-        |  tc `elem` trivially_inhabited-        -> case dcs of-             []    -> return (Left src_ty)-             (_:_) -> do var <- liftD $ mkPmId core_ty-                         let va = build_tm (PmVar var) dcs-                         return $ Right (tc, [InhabitationCandidate-                           { ic_val_abs = va, ic_tm_ct = mkIdEq var-                           , ic_ty_cs = emptyBag, ic_strict_arg_tys = [] }])--        |  pmIsClosedType core_ty && not (isAbstractTyCon tc)-           -- Don't consider abstract tycons since we don't know what their-           -- constructors are, which makes the results of coverage checking-           -- them extremely misleading.-        -> liftD $ do-             var  <- mkPmId core_ty -- it would be wrong to unify x-             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 ])-      -- For other types conservatively assume that they are inhabited.-      _other -> return (Left src_ty)--{- Note [Checking EmptyCase Expressions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Empty case expressions are strict on the scrutinee. That is, `case x of {}`-will force argument `x`. Hence, `checkMatches` is not sufficient for checking-empty cases, because it assumes that the match is not strict (which is true-for all other cases, apart from EmptyCase). This gave rise to #10746. Instead,-we do the following:--1. We normalise the outermost type family redex, data family redex or newtype,-   using pmTopNormaliseType_maybe (in types/FamInstEnv.hs). This computes 3-   things:-   (a) A normalised type src_ty, which is equal to the type of the scrutinee in-       source Haskell (does not normalise newtypes or data families)-   (b) The actual normalised type core_ty, which coincides with the result-       topNormaliseType_maybe. This type is not necessarily equal to the input-       type in source Haskell. And this is precicely the reason we compute (a)-       and (c): the reasoning happens with the underlying types, but both the-       patterns and types we print should respect newtypes and also show the-       family type constructors and not the representation constructors.--   (c) A list of all newtype data constructors dcs, each one corresponding to a-       newtype rewrite performed in (b).--   For an example see also Note [Type normalisation for EmptyCase]-   in types/FamInstEnv.hs.--2. Function checkEmptyCase' performs the check:-   - If core_ty is not an algebraic type, then we cannot check for-     inhabitation, so we emit (_ :: src_ty) as missing, conservatively assuming-     that the type is inhabited.-   - If core_ty is an algebraic type, then we unfold the scrutinee to all-     possible constructor patterns, using inhabitationCandidates, and then-     check each one for constraint satisfiability, same as we for normal-     pattern match checking.--%************************************************************************-%*                                                                      *-              Transform source syntax to *our* syntax-%*                                                                      *-%************************************************************************--}---- -------------------------------------------------------------------------- * Utilities--nullaryConPattern :: ConLike -> Pattern--- Nullary data constructor and nullary type constructor-nullaryConPattern con =-  PmCon { pm_con_con = con, pm_con_arg_tys = []-        , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = [] }-{-# INLINE nullaryConPattern #-}--truePattern :: Pattern-truePattern = nullaryConPattern (RealDataCon trueDataCon)-{-# INLINE truePattern #-}---- | A fake guard pattern (True <- _) used to represent cases we cannot handle-fake_pat :: Pattern-fake_pat = PmGrd { pm_grd_pv   = [truePattern]-                 , pm_grd_expr = PmExprOther (EWildPat noExt) }-{-# INLINE fake_pat #-}---- | Check whether a guard pattern is generated by the checker (unhandled)-isFakeGuard :: [Pattern] -> PmExpr -> Bool-isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther (EWildPat _))-  | c == trueDataCon = True-  | otherwise        = False-isFakeGuard _pats _e = False---- | Generate a `canFail` pattern vector of a specific type-mkCanFailPmPat :: Type -> DsM PatVec-mkCanFailPmPat ty = do-  var <- mkPmVar ty-  return [var, fake_pat]--vanillaConPattern :: ConLike -> [Type] -> PatVec -> Pattern--- ADT constructor pattern => no existentials, no local constraints-vanillaConPattern con arg_tys args =-  PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys-        , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = args }-{-# INLINE vanillaConPattern #-}---- | Create an empty list pattern of a given type-nilPattern :: Type -> Pattern-nilPattern ty =-  PmCon { pm_con_con = RealDataCon nilDataCon, pm_con_arg_tys = [ty]-        , pm_con_tvs = [], pm_con_dicts = []-        , pm_con_args = [] }-{-# INLINE nilPattern #-}--mkListPatVec :: Type -> PatVec -> PatVec -> PatVec-mkListPatVec ty xs ys = [PmCon { pm_con_con = RealDataCon consDataCon-                               , pm_con_arg_tys = [ty]-                               , pm_con_tvs = [], pm_con_dicts = []-                               , pm_con_args = xs++ys }]-{-# INLINE mkListPatVec #-}---- | Create a (non-overloaded) literal pattern-mkLitPattern :: HsLit GhcTc -> Pattern-mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit }-{-# INLINE mkLitPattern #-}---- -------------------------------------------------------------------------- * Transform (Pat Id) into of (PmPat Id)--translatePat :: FamInstEnvs -> Pat GhcTc -> DsM PatVec-translatePat fam_insts pat = case pat of-  WildPat  ty  -> mkPmVars [ty]-  VarPat _ id  -> return [PmVar (unLoc id)]-  ParPat _ p   -> translatePat fam_insts (unLoc p)-  LazyPat _ _  -> mkPmVars [hsPatType pat] -- like a variable--  -- ignore strictness annotations for now-  BangPat _ p  -> translatePat fam_insts (unLoc p)--  AsPat _ lid p -> do-     -- Note [Translating As Patterns]-    ps <- translatePat fam_insts (unLoc p)-    let [e] = map vaToPmExpr (coercePatVec ps)-        g   = PmGrd [PmVar (unLoc lid)] e-    return (ps ++ [g])--  SigPat _ p _ty -> translatePat fam_insts (unLoc p)--  -- See Note [Translate CoPats]-  CoPat _ wrapper p ty-    | isIdHsWrapper wrapper                   -> translatePat fam_insts p-    | WpCast co <-  wrapper, isReflexiveCo co -> translatePat fam_insts p-    | otherwise -> do-        ps      <- translatePat fam_insts p-        (xp,xe) <- mkPmId2Forms ty-        let g = mkGuard ps (mkHsWrap wrapper (unLoc xe))-        return [xp,g]--  -- (n + k)  ===>   x (True <- x >= k) (n <- x-k)-  NPlusKPat ty (dL->L _ _n) _k1 _k2 _ge _minus -> mkCanFailPmPat ty--  -- (fun -> pat)   ===>   x (pat <- fun x)-  ViewPat arg_ty lexpr lpat -> do-    ps <- translatePat fam_insts (unLoc lpat)-    -- See Note [Guards and Approximation]-    case all cantFailPattern ps of-      True  -> do-        (xp,xe) <- mkPmId2Forms arg_ty-        let g = mkGuard ps (HsApp noExt lexpr xe)-        return [xp,g]-      False -> mkCanFailPmPat arg_ty--  -- list-  ListPat (ListPatTc ty Nothing) ps -> do-    foldr (mkListPatVec ty) [nilPattern ty]-      <$> translatePatVec fam_insts (map unLoc ps)--  -- overloaded list-  ListPat (ListPatTc _elem_ty (Just (pat_ty, _to_list))) lpats -> do-    dflags <- getDynFlags-    if xopt LangExt.RebindableSyntax dflags-       then mkCanFailPmPat pat_ty-       else case splitListTyConApp_maybe pat_ty of-              Just e_ty -> translatePat fam_insts-                                        (ListPat (ListPatTc e_ty Nothing) lpats)-              Nothing   -> mkCanFailPmPat pat_ty-    -- (a) In the presence of RebindableSyntax, we don't know anything about-    --     `toList`, we should treat `ListPat` as any other view pattern.-    ---    -- (b) In the absence of RebindableSyntax,-    --     - If the pat_ty is `[a]`, then we treat the overloaded list pattern-    --       as ordinary list pattern. Although we can give an instance-    --       `IsList [Int]` (more specific than the default `IsList [a]`), in-    --       practice, we almost never do that. We assume the `_to_list` is-    --       the `toList` from `instance IsList [a]`.-    ---    --     - Otherwise, we treat the `ListPat` as ordinary view pattern.-    ---    -- See Trac #14547, especially comment#9 and comment#10.-    ---    -- Here we construct CanFailPmPat directly, rather can construct a view-    -- pattern and do further translation as an optimization, for the reason,-    -- see Note [Guards and Approximation].--  ConPatOut { pat_con     = (dL->L _ con)-            , pat_arg_tys = arg_tys-            , pat_tvs     = ex_tvs-            , pat_dicts   = dicts-            , pat_args    = ps } -> do-    groups <- allCompleteMatches con arg_tys-    case groups of-      [] -> mkCanFailPmPat (conLikeResTy con arg_tys)-      _  -> do-        args <- translateConPatVec fam_insts arg_tys ex_tvs con ps-        return [PmCon { pm_con_con     = con-                      , pm_con_arg_tys = arg_tys-                      , pm_con_tvs     = ex_tvs-                      , pm_con_dicts   = dicts-                      , pm_con_args    = args }]--  -- See Note [Translate Overloaded Literal for Exhaustiveness Checking]-  NPat _ (dL->L _ olit) mb_neg _-    | OverLit (OverLitTc False ty) (HsIsString src s) _ <- olit-    , isStringTy ty ->-        foldr (mkListPatVec charTy) [nilPattern charTy] <$>-          translatePatVec fam_insts-            (map (LitPat noExt . HsChar src) (unpackFS s))-    | otherwise -> return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) olit }]--  -- See Note [Translate Overloaded Literal for Exhaustiveness Checking]-  LitPat _ lit-    | HsString src s <- lit ->-        foldr (mkListPatVec charTy) [nilPattern charTy] <$>-          translatePatVec fam_insts-            (map (LitPat noExt . HsChar src) (unpackFS s))-    | otherwise -> return [mkLitPattern lit]--  TuplePat tys ps boxity -> do-    tidy_ps <- translatePatVec fam_insts (map unLoc ps)-    let tuple_con = RealDataCon (tupleDataCon boxity (length ps))-        tys' = case boxity of-                 Boxed -> tys-                 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon-                 Unboxed -> map getRuntimeRep tys ++ tys-    return [vanillaConPattern tuple_con tys' (concat tidy_ps)]--  SumPat ty p alt arity -> do-    tidy_p <- translatePat fam_insts (unLoc p)-    let sum_con = RealDataCon (sumDataCon alt arity)-    -- See Note [Unboxed tuple RuntimeRep vars] in TyCon-    return [vanillaConPattern sum_con (map getRuntimeRep ty ++ ty) tidy_p]--  -- ---------------------------------------------------------------------------  -- Not supposed to happen-  ConPatIn  {} -> panic "Check.translatePat: ConPatIn"-  SplicePat {} -> panic "Check.translatePat: SplicePat"-  XPat      {} -> panic "Check.translatePat: XPat"--{- Note [Translate Overloaded Literal for Exhaustiveness Checking]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The translation of @NPat@ in exhaustiveness checker is a bit different-from translation in pattern matcher.--  * In pattern matcher (see `tidyNPat' in deSugar/MatchLit.hs), we-    translate integral literals to HsIntPrim or HsWordPrim and translate-    overloaded strings to HsString.--  * In exhaustiveness checker, in `genCaseTmCs1/genCaseTmCs2`, we use-    `lhsExprToPmExpr` to generate uncovered set. In `hsExprToPmExpr`,-    however we generate `PmOLit` for HsOverLit, rather than refine-    `HsOverLit` inside `NPat` to HsIntPrim/HsWordPrim. If we do-    the same thing in `translatePat` as in `tidyNPat`, the exhaustiveness-    checker will fail to match the literals patterns correctly. See-    Trac #14546.--  In Note [Undecidable Equality for Overloaded Literals], we say: "treat-  overloaded literals that look different as different", but previously we-  didn't do such things.--  Now, we translate the literal value to match and the literal patterns-  consistently:--  * For integral literals, we parse both the integral literal value and-    the patterns as OverLit HsIntegral. For example:--      case 0::Int of-          0 -> putStrLn "A"-          1 -> putStrLn "B"-          _ -> putStrLn "C"--    When checking the exhaustiveness of pattern matching, we translate the 0-    in value position as PmOLit, but translate the 0 and 1 in pattern position-    as PmSLit. The inconsistency leads to the failure of eqPmLit to detect the-    equality and report warning of "Pattern match is redundant" on pattern 0,-    as reported in Trac #14546. In this patch we remove the specialization of-    OverLit patterns, and keep the overloaded number literal in pattern as it-    is to maintain the consistency. We know nothing about the `fromInteger`-    method (see Note [Undecidable Equality for Overloaded Literals]). Now we-    can capture the exhaustiveness of pattern 0 and the redundancy of pattern-    1 and _.--  * For string literals, we parse the string literals as HsString. When-    OverloadedStrings is enabled, it further be turned as HsOverLit HsIsString.-    For example:--      case "foo" of-          "foo" -> putStrLn "A"-          "bar" -> putStrLn "B"-          "baz" -> putStrLn "C"--    Previously, the overloaded string values are translated to PmOLit and the-    non-overloaded string values are translated to PmSLit. However the string-    patterns, both overloaded and non-overloaded, are translated to list of-    characters. The inconsistency leads to wrong warnings about redundant and-    non-exhaustive pattern matching warnings, as reported in Trac #14546.--    In order to catch the redundant pattern in following case:--      case "foo" of-          ('f':_) -> putStrLn "A"-          "bar" -> putStrLn "B"--    in this patch, we translate non-overloaded string literals, both in value-    position and pattern position, as list of characters. For overloaded string-    literals, we only translate it to list of characters only when it's type-    is stringTy, since we know nothing about the toString methods. But we know-    that if two overloaded strings are syntax equal, then they are equal. Then-    if it's type is not stringTy, we just translate it to PmOLit. We can still-    capture the exhaustiveness of pattern "foo" and the redundancy of pattern-    "bar" and "baz" in the following code:--      {-# LANGUAGE OverloadedStrings #-}-      main = do-        case "foo" of-            "foo" -> putStrLn "A"-            "bar" -> putStrLn "B"-            "baz" -> putStrLn "C"--  We must ensure that doing the same translation to literal values and patterns-  in `translatePat` and `hsExprToPmExpr`. The previous inconsistent work led to-  Trac #14546.--}---- | Translate a list of patterns (Note: each pattern is translated--- to a pattern vector but we do not concatenate the results).-translatePatVec :: FamInstEnvs -> [Pat GhcTc] -> DsM [PatVec]-translatePatVec fam_insts pats = mapM (translatePat fam_insts) pats---- | Translate a constructor pattern-translateConPatVec :: FamInstEnvs -> [Type] -> [TyVar]-                   -> ConLike -> HsConPatDetails GhcTc -> DsM PatVec-translateConPatVec fam_insts _univ_tys _ex_tvs _ (PrefixCon ps)-  = concat <$> translatePatVec fam_insts (map unLoc ps)-translateConPatVec fam_insts _univ_tys _ex_tvs _ (InfixCon p1 p2)-  = concat <$> translatePatVec fam_insts (map unLoc [p1,p2])-translateConPatVec fam_insts  univ_tys  ex_tvs c (RecCon (HsRecFields fs _))-    -- Nothing matched. Make up some fresh term variables-  | null fs        = mkPmVars arg_tys-    -- The data constructor was not defined using record syntax. For the-    -- pattern to be in record syntax it should be empty (e.g. Just {}).-    -- So just like the previous case.-  | null orig_lbls = ASSERT(null matched_lbls) mkPmVars arg_tys-    -- Some of the fields appear, in the original order (there may be holes).-    -- Generate a simple constructor pattern and make up fresh variables for-    -- the rest of the fields-  | matched_lbls `subsetOf` orig_lbls-  = ASSERT(orig_lbls `equalLength` arg_tys)-      let translateOne (lbl, ty) = case lookup lbl matched_pats of-            Just p  -> translatePat fam_insts p-            Nothing -> mkPmVars [ty]-      in  concatMapM translateOne (zip orig_lbls arg_tys)-    -- The fields that appear are not in the correct order. Make up fresh-    -- variables for all fields and add guards after matching, to force the-    -- evaluation in the correct order.-  | otherwise = do-      arg_var_pats    <- mkPmVars arg_tys-      translated_pats <- forM matched_pats $ \(x,pat) -> do-        pvec <- translatePat fam_insts pat-        return (x, pvec)--      let zipped = zip orig_lbls [ x | PmVar x <- arg_var_pats ]-          guards = map (\(name,pvec) -> case lookup name zipped of-                            Just x  -> PmGrd pvec (PmExprVar (idName x))-                            Nothing -> panic "translateConPatVec: lookup")-                       translated_pats--      return (arg_var_pats ++ guards)-  where-    -- The actual argument types (instantiated)-    arg_tys = conLikeInstOrigArgTys c (univ_tys ++ mkTyVarTys ex_tvs)--    -- Some label information-    orig_lbls    = map flSelector $ conLikeFieldLabels c-    matched_pats = [ (getName (unLoc (hsRecFieldId x)), unLoc (hsRecFieldArg x))-                   | (dL->L _ x) <- fs]-    matched_lbls = [ name | (name, _pat) <- matched_pats ]--    subsetOf :: Eq a => [a] -> [a] -> Bool-    subsetOf []     _  = True-    subsetOf (_:_)  [] = False-    subsetOf (x:xs) (y:ys)-      | x == y    = subsetOf    xs  ys-      | otherwise = subsetOf (x:xs) ys---- Translate a single match-translateMatch :: FamInstEnvs -> LMatch GhcTc (LHsExpr GhcTc)-               -> DsM (PatVec,[PatVec])-translateMatch fam_insts (dL->L _ (Match { m_pats = lpats, m_grhss = grhss })) =-  do-  pats'   <- concat <$> translatePatVec fam_insts pats-  guards' <- mapM (translateGuards fam_insts) guards-  return (pats', guards')-  where-    extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc]-    extractGuards (dL->L _ (GRHS _ gs _)) = map unLoc gs-    extractGuards _                       = panic "translateMatch"--    pats   = map unLoc lpats-    guards = map extractGuards (grhssGRHSs grhss)-translateMatch _ _ = panic "translateMatch"---- -------------------------------------------------------------------------- * Transform source guards (GuardStmt Id) to PmPats (Pattern)---- | Translate a list of guard statements to a pattern vector-translateGuards :: FamInstEnvs -> [GuardStmt GhcTc] -> DsM PatVec-translateGuards fam_insts guards = do-  all_guards <- concat <$> mapM (translateGuard fam_insts) guards-  return (replace_unhandled all_guards)-  -- It should have been (return all_guards) but it is too expressive.-  -- Since the term oracle does not handle all constraints we generate,-  -- we (hackily) replace all constraints the oracle cannot handle with a-  -- single one (we need to know if there is a possibility of falure).-  -- See Note [Guards and Approximation] for all guard-related approximations-  -- we implement.-  where-    replace_unhandled :: PatVec -> PatVec-    replace_unhandled gv-      | any_unhandled gv = fake_pat : [ p | p <- gv, shouldKeep p ]-      | otherwise        = gv--    any_unhandled :: PatVec -> Bool-    any_unhandled gv = any (not . shouldKeep) gv--    shouldKeep :: Pattern -> Bool-    shouldKeep p-      | PmVar {} <- p      = True-      | PmCon {} <- p      = singleConstructor (pm_con_con p)-                             && all shouldKeep (pm_con_args p)-    shouldKeep (PmGrd pv e)-      | all shouldKeep pv  = True-      | isNotPmExprOther e = True  -- expensive but we want it-    shouldKeep _other_pat  = False -- let the rest..---- | Check whether a pattern can fail to match-cantFailPattern :: Pattern -> Bool-cantFailPattern p-  | PmVar {} <- p = True-  | PmCon {} <- p = singleConstructor (pm_con_con p)-                    && all cantFailPattern (pm_con_args p)-cantFailPattern (PmGrd pv _e)-                  = all cantFailPattern pv-cantFailPattern _ = False---- | Translate a guard statement to Pattern-translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM PatVec-translateGuard fam_insts guard = case guard of-  BodyStmt _   e _ _ -> translateBoolGuard e-  LetStmt  _   binds -> translateLet (unLoc binds)-  BindStmt _ p e _ _ -> translateBind fam_insts p e-  LastStmt        {} -> panic "translateGuard LastStmt"-  ParStmt         {} -> panic "translateGuard ParStmt"-  TransStmt       {} -> panic "translateGuard TransStmt"-  RecStmt         {} -> panic "translateGuard RecStmt"-  ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt"-  XStmtLR         {} -> panic "translateGuard RecStmt"---- | Translate let-bindings-translateLet :: HsLocalBinds GhcTc -> DsM PatVec-translateLet _binds = return []---- | Translate a pattern guard-translateBind :: FamInstEnvs -> LPat GhcTc -> LHsExpr GhcTc -> DsM PatVec-translateBind fam_insts (dL->L _ p) e = do-  ps <- translatePat fam_insts p-  return [mkGuard ps (unLoc e)]---- | Translate a boolean guard-translateBoolGuard :: LHsExpr GhcTc -> DsM PatVec-translateBoolGuard e-  | isJust (isTrueLHsExpr e) = return []-    -- The formal thing to do would be to generate (True <- True)-    -- but it is trivial to solve so instead we give back an empty-    -- PatVec for efficiency-  | otherwise = return [mkGuard [truePattern] (unLoc e)]--{- Note [Guards and Approximation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Even if the algorithm is really expressive, the term oracle we use is not.-Hence, several features are not translated *properly* but we approximate.-The list includes:--1. View Patterns------------------A view pattern @(f -> p)@ should be translated to @x (p <- f x)@. The term-oracle does not handle function applications so we know that the generated-constraints will not be handled at the end. Hence, we distinguish between two-cases:-  a) Pattern @p@ cannot fail. Then this is just a binding and we do the *right-     thing*.-  b) Pattern @p@ can fail. This means that when checking the guard, we will-     generate several cases, with no useful information. E.g.:--       h (f -> [a,b]) = ...-       h x ([a,b] <- f x) = ...--       uncovered set = { [x |> { False ~ (f x ~ [])            }]-                       , [x |> { False ~ (f x ~ (t1:[]))       }]-                       , [x |> { False ~ (f x ~ (t1:t2:t3:t4)) }] }--     So we have two problems:-       1) Since we do not print the constraints in the general case (they may-          be too many), the warning will look like this:--            Pattern match(es) are non-exhaustive-            In an equation for `h':-                Patterns not matched:-                    _-                    _-                    _-          Which is not short and not more useful than a single underscore.-       2) The size of the uncovered set increases a lot, without gaining more-          expressivity in our warnings.--     Hence, in this case, we replace the guard @([a,b] <- f x)@ with a *dummy*-     @fake_pat@: @True <- _@. That is, we record that there is a possibility-     of failure but we minimize it to a True/False. This generates a single-     warning and much smaller uncovered sets.--2. Overloaded Lists---------------------An overloaded list @[...]@ should be translated to @x ([...] <- toList x)@. The-problem is exactly like above, as its solution. For future reference, the code-below is the *right thing to do*:--   ListPat (ListPatTc elem_ty (Just (pat_ty, _to_list))) lpats-     otherwise -> do-       (xp, xe) <- mkPmId2Forms pat_ty-       ps       <- translatePatVec (map unLoc lpats)-       let pats = foldr (mkListPatVec elem_ty) [nilPattern elem_ty] ps-           g    = mkGuard pats (HsApp (noLoc to_list) xe)-       return [xp,g]--3. Overloaded Literals------------------------The case with literals is a bit different. a literal @l@ should be translated-to @x (True <- x == from l)@. Since we want to have better warnings for-overloaded literals as it is a very common feature, we treat them differently.-They are mainly covered in Note [Undecidable Equality for Overloaded Literals]-in PmExpr.--4. N+K Patterns & Pattern Synonyms-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-An n+k pattern (n+k) should be translated to @x (True <- x >= k) (n <- x-k)@.-Since the only pattern of the three that causes failure is guard @(n <- x-k)@,-and has two possible outcomes. Hence, there is no benefit in using a dummy and-we implement the proper thing. Pattern synonyms are simply not implemented yet.-Hence, to be conservative, we generate a dummy pattern, assuming that the-pattern can fail.--5. Actual Guards------------------During translation, boolean guards and pattern guards are translated properly.-Let bindings though are omitted by function @translateLet@. Since they are lazy-bindings, we do not actually want to generate a (strict) equality (like we do-in the pattern bind case). Hence, we safely drop them.--Additionally, top-level guard translation (performed by @translateGuards@)-replaces guards that cannot be reasoned about (like the ones we described in-1-4) with a single @fake_pat@ to record the possibility of failure to match.--Note [Translate CoPats]-~~~~~~~~~~~~~~~~~~~~~~~-The pattern match checker did not know how to handle coerced patterns `CoPat`-efficiently, which gave rise to #11276. The original approach translated-`CoPat`s:--    pat |> co    ===>    x (pat <- (e |> co))--Instead, we now check whether the coercion is a hole or if it is just refl, in-which case we can drop it. Unfortunately, data families generate useful-coercions so guards are still generated in these cases and checking data-families is not really efficient.--%************************************************************************-%*                                                                      *-                 Utilities for Pattern Match Checking-%*                                                                      *-%************************************************************************--}---- ------------------------------------------------------------------------------- * Basic utilities---- | Get the type out of a PmPat. For guard patterns (ps <- e) we use the type--- of the first (or the single -WHEREVER IT IS- valid to use?) pattern-pmPatType :: PmPat p -> Type-pmPatType (PmCon { pm_con_con = con, pm_con_arg_tys = tys })-  = conLikeResTy con tys-pmPatType (PmVar  { pm_var_id  = x }) = idType x-pmPatType (PmLit  { pm_lit_lit = l }) = pmLitType l-pmPatType (PmNLit { pm_lit_id  = x }) = idType x-pmPatType (PmGrd  { pm_grd_pv  = pv })-  = ASSERT(patVecArity pv == 1) (pmPatType p)-  where Just p = find ((==1) . patternArity) pv---- | Information about a conlike that is relevant to coverage checking.--- It is called an \"inhabitation candidate\" since it is a value which may--- possibly inhabit some type, but only if its term constraint ('ic_tm_ct')--- and type constraints ('ic_ty_cs') are permitting, and if all of its strict--- argument types ('ic_strict_arg_tys') are inhabitable.--- See @Note [Extensions to GADTs Meet Their Match]@.-data InhabitationCandidate =-  InhabitationCandidate-  { ic_val_abs        :: ValAbs-  , ic_tm_ct          :: ComplexEq-  , ic_ty_cs          :: Bag EvVar-  , ic_strict_arg_tys :: [Type]-  }--{--Note [Extensions to GADTs Meet Their Match]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The GADTs Meet Their Match paper presents the formalism that GHC's coverage-checker adheres to. Since the paper's publication, there have been some-additional features added to the coverage checker which are not described in-the paper. This Note serves as a reference for these new features.---------- Strict argument type constraints--------In the ConVar case of clause processing, each conlike K traditionally-generates two different forms of constraints:--* A term constraint (e.g., x ~ K y1 ... yn)-* Type constraints from the conlike's context (e.g., if K has type-  forall bs. Q => s1 .. sn -> T tys, then Q would be its type constraints)--As it turns out, these alone are not enough to detect a certain class of-unreachable code. Consider the following example (adapted from #15305):--  data K = K1 | K2 !Void--  f :: K -> ()-  f K1 = ()--Even though `f` doesn't match on `K2`, `f` is exhaustive in its patterns. Why?-Because it's impossible to construct a terminating value of type `K` using the-`K2` constructor, and thus it's impossible for `f` to ever successfully match-on `K2`.--The reason is because `K2`'s field of type `Void` is //strict//. Because there-are no terminating values of type `Void`, any attempt to construct something-using `K2` will immediately loop infinitely or throw an exception due to the-strictness annotation. (If the field were not strict, then `f` could match on,-say, `K2 undefined` or `K2 (let x = x in x)`.)--Since neither the term nor type constraints mentioned above take strict-argument types into account, we make use of the `nonVoid` function to-determine whether a strict type is inhabitable by a terminating value or not.--`nonVoid ty` returns True when either:-1. `ty` has at least one InhabitationCandidate for which both its term and type-   constraints are satifiable, and `nonVoid` returns `True` for all of the-   strict argument types in that InhabitationCandidate.-2. We're unsure if it's inhabited by a terminating value.--`nonVoid ty` returns False when `ty` is definitely uninhabited by anything-(except bottom). Some examples:--* `nonVoid Void` returns False, since Void has no InhabitationCandidates.-  (This is what lets us discard the `K2` constructor in the earlier example.)-* `nonVoid (Int :~: Int)` returns True, since it has an InhabitationCandidate-  (through the Refl constructor), and its term constraint (x ~ Refl) and-  type constraint (Int ~ Int) are satisfiable.-* `nonVoid (Int :~: Bool)` returns False. Although it has an-  InhabitationCandidate (by way of Refl), its type constraint (Int ~ Bool) is-  not satisfiable.-* Given the following definition of `MyVoid`:--    data MyVoid = MkMyVoid !Void--  `nonVoid MyVoid` returns False. The InhabitationCandidate for the MkMyVoid-  constructor contains Void as a strict argument type, and since `nonVoid Void`-  returns False, that InhabitationCandidate is discarded, leaving no others.--* Performance considerations--We must be careful when recursively calling `nonVoid` on the strict argument-types of an InhabitationCandidate, because doing so naïvely can cause GHC to-fall into an infinite loop. Consider the following example:--  data Abyss = MkAbyss !Abyss--  stareIntoTheAbyss :: Abyss -> a-  stareIntoTheAbyss x = case x of {}--In principle, stareIntoTheAbyss is exhaustive, since there is no way to-construct a terminating value using MkAbyss. However, both the term and type-constraints for MkAbyss are satisfiable, so the only way one could determine-that MkAbyss is unreachable is to check if `nonVoid Abyss` returns False.-There is only one InhabitationCandidate for Abyss—MkAbyss—and both its term-and type constraints are satisfiable, so we'd need to check if `nonVoid Abyss`-returns False... and now we've entered an infinite loop!--To avoid this sort of conundrum, `nonVoid` uses a simple test to detect the-presence of recursive types (through `checkRecTc`), and if recursion is-detected, we bail out and conservatively assume that the type is inhabited by-some terminating value. This avoids infinite loops at the expense of making-the coverage checker incomplete with respect to functions like-stareIntoTheAbyss above. Then again, the same problem occurs with recursive-newtypes, like in the following code:--  newtype Chasm = MkChasm Chasm--  gazeIntoTheChasm :: Chasm -> a-  gazeIntoTheChasm x = case x of {} -- Erroneously warned as non-exhaustive--So this limitation is somewhat understandable.--Note that even with this recursion detection, there is still a possibility that-`nonVoid` can run in exponential time. Consider the following data type:--  data T = MkT !T !T !T--If we call `nonVoid` on each of its fields, that will require us to once again-check if `MkT` is inhabitable in each of those three fields, which in turn will-require us to check if `MkT` is inhabitable again... As you can see, the-branching factor adds up quickly, and if the recursion depth limit is, say,-100, then `nonVoid T` will effectively take forever.--To mitigate this, we check the branching factor every time we are about to call-`nonVoid` on a list of strict argument types. If the branching factor exceeds 1-(i.e., if there is potential for exponential runtime), then we limit the-maximum recursion depth to 1 to mitigate the problem. If the branching factor-is exactly 1 (i.e., we have a linear chain instead of a tree), then it's okay-to stick with a larger maximum recursion depth.--Another microoptimization applies to data types like this one:--  data S a = ![a] !T--Even though there is a strict field of type [a], it's quite silly to call-nonVoid on it, since it's "obvious" that it is inhabitable. To make this-intuition formal, we say that a type is definitely inhabitable (DI) if:--  * It has at least one constructor C such that:-    1. C has no equality constraints (since they might be unsatisfiable)-    2. C has no strict argument types (since they might be uninhabitable)--It's relatively cheap to cheap if a type is DI, so before we call `nonVoid`-on a list of strict argument types, we filter out all of the DI ones.--}--instance Outputable InhabitationCandidate where-  ppr (InhabitationCandidate { ic_val_abs = va, ic_tm_ct = tm_ct-                             , ic_ty_cs = ty_cs-                             , ic_strict_arg_tys = strict_arg_tys }) =-    text "InhabitationCandidate" <+>-      vcat [ text "ic_val_abs        =" <+> ppr va-           , text "ic_tm_ct          =" <+> ppr tm_ct-           , text "ic_ty_cs          =" <+> ppr ty_cs-           , text "ic_strict_arg_tys =" <+> ppr strict_arg_tys ]---- | Generate an 'InhabitationCandidate' for a given conlike (generate--- fresh variables of the appropriate type for arguments)-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------  *  'x' is the variable for which we encode an equality constraint---     in the term oracle------ 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 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-      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'-  -- All constraints bound by the constructor (alpha-renamed)-  let theta_cs = substTheta subst (eqSpecPreds eq_spec ++ thetas)-  evvars <- mapM (nameType "pm") theta_cs-  let con_abs  = PmCon { pm_con_con     = con-                       , pm_con_arg_tys = tc_args-                       , pm_con_tvs     = ex_tvs'-                       , pm_con_dicts   = evvars-                       , pm_con_args    = arguments }-      strict_arg_tys = filterByList arg_is_banged arg_tys'-  return $ InhabitationCandidate-           { ic_val_abs        = con_abs-           , ic_tm_ct          = (PmExprVar (idName x), vaToPmExpr con_abs)-           , ic_ty_cs          = listToBag evvars-           , ic_strict_arg_tys = strict_arg_tys-           }---- ------------------------------------------------------------------------------- * More smart constructors and fresh variable generation---- | Create a guard pattern-mkGuard :: PatVec -> HsExpr GhcTc -> Pattern-mkGuard pv e-  | all cantFailPattern pv = PmGrd pv expr-  | PmExprOther {} <- expr = fake_pat-  | otherwise              = PmGrd pv expr-  where-    expr = hsExprToPmExpr e---- | Create a term equality of the form: `(False ~ (x ~ lit))`-mkNegEq :: Id -> PmLit -> ComplexEq-mkNegEq x l = (falsePmExpr, PmExprVar (idName x) `PmExprEq` PmExprLit l)-{-# INLINE mkNegEq #-}---- | Create a term equality of the form: `(x ~ lit)`-mkPosEq :: Id -> PmLit -> ComplexEq-mkPosEq x l = (PmExprVar (idName x), PmExprLit l)-{-# INLINE mkPosEq #-}---- | Create a term equality of the form: `(x ~ x)`--- (always discharged by the term oracle)-mkIdEq :: Id -> ComplexEq-mkIdEq x = (PmExprVar name, PmExprVar name)-  where name = idName x-{-# INLINE mkIdEq #-}---- | Generate a variable pattern of a given type-mkPmVar :: Type -> DsM (PmPat p)-mkPmVar ty = PmVar <$> mkPmId ty-{-# INLINE mkPmVar #-}---- | Generate many variable patterns, given a list of types-mkPmVars :: [Type] -> DsM PatVec-mkPmVars tys = mapM mkPmVar tys-{-# INLINE mkPmVars #-}---- | Generate a fresh `Id` of a given type-mkPmId :: Type -> DsM Id-mkPmId ty = getUniqueM >>= \unique ->-  let occname = mkVarOccFS $ fsLit "$pm"-      name    = mkInternalName unique occname noSrcSpan-  in  return (mkLocalId name ty)---- | Generate a fresh term variable of a given and return it in two forms:--- * A variable pattern--- * A variable expression-mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc)-mkPmId2Forms ty = do-  x <- mkPmId ty-  return (PmVar x, noLoc (HsVar noExt (noLoc x)))---- ------------------------------------------------------------------------------- * Converting between Value Abstractions, Patterns and PmExpr---- | Convert a value abstraction an expression-vaToPmExpr :: ValAbs -> PmExpr-vaToPmExpr (PmCon  { pm_con_con = c, pm_con_args = ps })-  = PmExprCon c (map vaToPmExpr ps)-vaToPmExpr (PmVar  { pm_var_id  = x }) = PmExprVar (idName x)-vaToPmExpr (PmLit  { pm_lit_lit = l }) = PmExprLit l-vaToPmExpr (PmNLit { pm_lit_id  = x }) = PmExprVar (idName x)---- | Convert a pattern vector to a list of value abstractions by dropping the--- guards (See Note [Translating As Patterns])-coercePatVec :: PatVec -> [ValAbs]-coercePatVec pv = concatMap coercePmPat pv---- | Convert a pattern to a list of value abstractions (will be either an empty--- list if the pattern is a guard pattern, or a singleton list in all other--- cases) by dropping the guards (See Note [Translating As Patterns])-coercePmPat :: Pattern -> [ValAbs]-coercePmPat (PmVar { pm_var_id  = x }) = [PmVar { pm_var_id  = x }]-coercePmPat (PmLit { pm_lit_lit = l }) = [PmLit { pm_lit_lit = l }]-coercePmPat (PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys-                   , pm_con_tvs = tvs, pm_con_dicts = dicts-                   , pm_con_args = args })-  = [PmCon { pm_con_con  = con, pm_con_arg_tys = arg_tys-           , pm_con_tvs  = tvs, pm_con_dicts = dicts-           , pm_con_args = coercePatVec args }]-coercePmPat (PmGrd {}) = [] -- drop the guards---- | Check whether a data constructor is the only way to construct--- a data type.-singleConstructor :: ConLike -> Bool-singleConstructor (RealDataCon dc) =-  case tyConDataCons (dataConTyCon dc) of-    [_] -> True-    _   -> False-singleConstructor _ = False---- | For a given conlike, finds all the sets of patterns which could--- be relevant to that conlike by consulting the result type.------ These come from two places.---  1. From data constructors defined with the result type constructor.---  2. From `COMPLETE` pragmas which have the same type as the result---     type constructor. Note that we only use `COMPLETE` pragmas---     *all* of whose pattern types match. See #14135-allCompleteMatches :: ConLike -> [Type] -> DsM [(Provenance, [ConLike])]-allCompleteMatches cl tys = do-  let fam = case cl of-           RealDataCon dc ->-            [(FromBuiltin, map RealDataCon (tyConDataCons (dataConTyCon dc)))]-           PatSynCon _    -> []-      ty  = conLikeResTy cl tys-  pragmas <- case splitTyConApp_maybe ty of-               Just (tc, _) -> dsGetCompleteMatches tc-               Nothing      -> return []-  let fams cm = (FromComplete,) <$>-                mapM dsLookupConLike (completeMatchConLikes cm)-  from_pragma <- filter (\(_,m) -> isValidCompleteMatch ty m) <$>-                mapM fams pragmas-  let final_groups = fam ++ from_pragma-  return final_groups-    where-      -- Check that all the pattern synonym return types in a `COMPLETE`-      -- pragma subsume the type we're matching.-      -- See Note [Filtering out non-matching COMPLETE sets]-      isValidCompleteMatch :: Type -> [ConLike] -> Bool-      isValidCompleteMatch ty = all go-        where-          go (RealDataCon {}) = True-          go (PatSynCon psc)  = isJust $ flip tcMatchTy ty $ patSynResTy-                                       $ patSynSig psc--          patSynResTy (_, _, _, _, _, res_ty) = res_ty--{--Note [Filtering out non-matching COMPLETE sets]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Currently, conlikes in a COMPLETE set are simply grouped by the-type constructor heading the return type. This is nice and simple, but it does-mean that there are scenarios when a COMPLETE set might be incompatible with-the type of a scrutinee. For instance, consider (from #14135):--  data Foo a = Foo1 a | Foo2 a--  pattern MyFoo2 :: Int -> Foo Int-  pattern MyFoo2 i = Foo2 i--  {-# COMPLETE Foo1, MyFoo2 #-}--  f :: Foo a -> a-  f (Foo1 x) = x--`f` has an incomplete pattern-match, so when choosing which constructors to-report as unmatched in a warning, GHC must choose between the original set of-data constructors {Foo1, Foo2} and the COMPLETE set {Foo1, MyFoo2}. But observe-that GHC shouldn't even consider the COMPLETE set as a possibility: the return-type of MyFoo2, Foo Int, does not match the type of the scrutinee, Foo a, since-there's no substitution `s` such that s(Foo Int) = Foo a.--To ensure that GHC doesn't pick this COMPLETE set, it checks each pattern-synonym constructor's return type matches the type of the scrutinee, and if one-doesn't, then we remove the whole COMPLETE set from consideration.--One might wonder why GHC only checks /pattern synonym/ constructors, and not-/data/ constructors as well. The reason is because that the type of a-GADT constructor very well may not match the type of a scrutinee, and that's-OK. Consider this example (from #14059):--  data SBool (z :: Bool) where-    SFalse :: SBool False-    STrue  :: SBool True--  pattern STooGoodToBeTrue :: forall (z :: Bool). ()-                           => z ~ True-                           => SBool z-  pattern STooGoodToBeTrue = STrue-  {-# COMPLETE SFalse, STooGoodToBeTrue #-}--  wobble :: SBool z -> Bool-  wobble STooGoodToBeTrue = True--In the incomplete pattern match for `wobble`, we /do/ want to warn that SFalse-should be matched against, even though its type, SBool False, does not match-the scrutinee type, SBool z.--}---- -------------------------------------------------------------------------- * Types and constraints--newEvVar :: Name -> Type -> EvVar-newEvVar name ty = mkLocalId name ty--nameType :: String -> Type -> DsM EvVar-nameType name ty = do-  unique <- getUniqueM-  let occname = mkVarOccFS (fsLit (name++"_"++show unique))-      idname  = mkInternalName unique occname noSrcSpan-  return (newEvVar idname ty)--{--%************************************************************************-%*                                                                      *-                              The type oracle-%*                                                                      *-%************************************************************************--}---- | Check whether a set of type constraints is satisfiable.-tyOracle :: Bag EvVar -> PmM Bool-tyOracle evs-  = liftD $-    do { ((_warns, errs), res) <- initTcDsForSolver $ tcCheckSatisfiability evs-       ; case res of-            Just sat -> return sat-            Nothing  -> pprPanic "tyOracle" (vcat $ pprErrMsgBagWithLoc errs) }--{--%************************************************************************-%*                                                                      *-                             Sanity Checks-%*                                                                      *-%************************************************************************--}---- | The arity of a pattern/pattern vector is the--- number of top-level patterns that are not guards-type PmArity = Int---- | Compute the arity of a pattern vector-patVecArity :: PatVec -> PmArity-patVecArity = sum . map patternArity---- | Compute the arity of a pattern-patternArity :: Pattern -> PmArity-patternArity (PmGrd {}) = 0-patternArity _other_pat = 1--{--%************************************************************************-%*                                                                      *-            Heart of the algorithm: Function pmcheck-%*                                                                      *-%************************************************************************--Main functions are:--* mkInitialUncovered :: [Id] -> PmM Uncovered--  Generates the initial uncovered set. Term and type constraints in scope-  are checked, if they are inconsistent, the set is empty, otherwise, the-  set contains only a vector of variables with the constraints in scope.--* pmcheck :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult--  Checks redundancy, coverage and inaccessibility, using auxilary functions-  `pmcheckGuards` and `pmcheckHd`. Mainly handles the guard case which is-  common in all three checks (see paper) and calls `pmcheckGuards` when the-  whole clause is checked, or `pmcheckHd` when the pattern vector does not-  start with a guard.--* pmcheckGuards :: [PatVec] -> ValVec -> PmM PartialResult--  Processes the guards.--* pmcheckHd :: Pattern -> PatVec -> [PatVec]-          -> ValAbs -> ValVec -> PmM PartialResult--  Worker: This function implements functions `covered`, `uncovered` and-  `divergent` from the paper at once. Slightly different from the paper because-  it does not even produce the covered and uncovered sets. Since we only care-  about whether a clause covers SOMETHING or if it may forces ANY argument, we-  only store a boolean in both cases, for efficiency.--}---- | Lift a pattern matching action from a single value vector abstration to a--- value set abstraction, but calling it on every vector and the combining the--- results.-runMany :: (ValVec -> PmM PartialResult) -> (Uncovered -> PmM PartialResult)-runMany _ [] = return mempty-runMany pm (m:ms) = mappend <$> pm m <*> runMany pm ms---- | Generate the initial uncovered set. It initializes the--- delta with all term and type constraints in scope.-mkInitialUncovered :: [Id] -> PmM Uncovered-mkInitialUncovered vars = do-  delta <- pmInitialTmTyCs-  let patterns = map PmVar vars-  return [ValVec patterns delta]---- | Increase the counter for elapsed algorithm iterations, check that the--- limit is not exceeded and call `pmcheck`-pmcheckI :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult-pmcheckI ps guards vva = do-  n <- liftD incrCheckPmIterDs-  tracePm "pmCheck" (ppr n <> colon <+> pprPatVec ps-                        $$ hang (text "guards:") 2 (vcat (map pprPatVec guards))-                        $$ pprValVecDebug vva)-  res <- pmcheck ps guards vva-  tracePm "pmCheckResult:" (ppr res)-  return res-{-# INLINE pmcheckI #-}---- | Increase the counter for elapsed algorithm iterations, check that the--- limit is not exceeded and call `pmcheckGuards`-pmcheckGuardsI :: [PatVec] -> ValVec -> PmM PartialResult-pmcheckGuardsI gvs vva = liftD incrCheckPmIterDs >> pmcheckGuards gvs vva-{-# INLINE pmcheckGuardsI #-}---- | Increase the counter for elapsed algorithm iterations, check that the--- limit is not exceeded and call `pmcheckHd`-pmcheckHdI :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec-           -> PmM PartialResult-pmcheckHdI p ps guards va vva = do-  n <- liftD incrCheckPmIterDs-  tracePm "pmCheckHdI" (ppr n <> colon <+> pprPmPatDebug p-                        $$ pprPatVec ps-                        $$ hang (text "guards:") 2 (vcat (map pprPatVec guards))-                        $$ pprPmPatDebug va-                        $$ pprValVecDebug vva)--  res <- pmcheckHd p ps guards va vva-  tracePm "pmCheckHdI: res" (ppr res)-  return res-{-# INLINE pmcheckHdI #-}---- | Matching function: Check simultaneously a clause (takes separately the--- patterns and the list of guards) for exhaustiveness, redundancy and--- inaccessibility.-pmcheck :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult-pmcheck [] guards vva@(ValVec [] _)-  | null guards = return $ mempty { presultCovered = Covered }-  | otherwise   = pmcheckGuardsI guards vva---- Guard-pmcheck (p@(PmGrd pv e) : ps) guards vva@(ValVec vas delta)-    -- short-circuit if the guard pattern is useless.-    -- we just have two possible outcomes: fail here or match and recurse-    -- none of the two contains any useful information about the failure-    -- though. So just have these two cases but do not do all the boilerplate-  | isFakeGuard pv e = forces . mkCons vva <$> pmcheckI ps guards vva-  | otherwise = do-      y <- liftD $ mkPmId (pmPatType p)-      let tm_state = extendSubst y e (delta_tm_cs delta)-          delta'   = delta { delta_tm_cs = tm_state }-      utail <$> pmcheckI (pv ++ ps) guards (ValVec (PmVar y : vas) delta')--pmcheck [] _ (ValVec (_:_) _) = panic "pmcheck: nil-cons"-pmcheck (_:_) _ (ValVec [] _) = panic "pmcheck: cons-nil"--pmcheck (p:ps) guards (ValVec (va:vva) delta)-  = pmcheckHdI p ps guards va (ValVec vva delta)---- | Check the list of guards-pmcheckGuards :: [PatVec] -> ValVec -> PmM PartialResult-pmcheckGuards []       vva = return (usimple [vva])-pmcheckGuards (gv:gvs) vva = do-  (PartialResult prov1 cs vsa ds) <- pmcheckI gv [] vva-  (PartialResult prov2 css vsas dss) <- runMany (pmcheckGuardsI gvs) vsa-  return $ PartialResult (prov1 `mappend` prov2)-                         (cs `mappend` css)-                         vsas-                         (ds `mappend` dss)---- | Worker function: Implements all cases described in the paper for all three--- functions (`covered`, `uncovered` and `divergent`) apart from the `Guard`--- cases which are handled by `pmcheck`-pmcheckHd :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec-          -> PmM PartialResult---- Var-pmcheckHd (PmVar x) ps guards va (ValVec vva delta)-  | Just tm_state <- solveOneEq (delta_tm_cs delta)-                                (PmExprVar (idName x), vaToPmExpr va)-  = ucon va <$> pmcheckI ps guards (ValVec vva (delta {delta_tm_cs = tm_state}))-  | otherwise = return mempty---- ConCon-pmcheckHd ( p@(PmCon { pm_con_con = c1, pm_con_tvs = ex_tvs1-                     , pm_con_args = args1})) ps guards-          (va@(PmCon { pm_con_con = c2, pm_con_tvs = ex_tvs2-                     , pm_con_args = args2})) (ValVec vva delta)-  | c1 /= c2  =-    return (usimple [ValVec (va:vva) delta])-  | otherwise = do-    let to_evvar tv1 tv2 = nameType "pmConCon" $-                           mkPrimEqPred (mkTyVarTy tv1) (mkTyVarTy tv2)-        mb_to_evvar tv1 tv2-            -- If we have identical constructors but different existential-            -- tyvars, then generate extra equality constraints to ensure the-            -- existential tyvars.-            -- See Note [Coverage checking and existential tyvars].-          | tv1 == tv2 = pure Nothing-          | otherwise  = Just <$> to_evvar tv1 tv2-    evvars <- (listToBag . catMaybes) <$>-              ASSERT(ex_tvs1 `equalLength` ex_tvs2)-              liftD (zipWithM mb_to_evvar ex_tvs1 ex_tvs2)-    let delta' = delta { delta_ty_cs = evvars `unionBags` delta_ty_cs delta }-    kcon c1 (pm_con_arg_tys p) (pm_con_tvs p) (pm_con_dicts p)-      <$> pmcheckI (args1 ++ ps) guards (ValVec (args2 ++ vva) delta')---- LitLit-pmcheckHd (PmLit l1) ps guards (va@(PmLit l2)) vva =-  case eqPmLit l1 l2 of-    True  -> ucon va <$> pmcheckI ps guards vva-    False -> return $ ucon va (usimple [vva])---- ConVar-pmcheckHd (p@(PmCon { pm_con_con = con, pm_con_arg_tys = tys }))-          ps guards-          (PmVar x) (ValVec vva delta) = do-  (prov, complete_match) <- select =<< liftD (allCompleteMatches con tys)--  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-                            , ic_ty_cs = ty_cs-                            , ic_strict_arg_tys = strict_arg_tys } -> do-    mb_sat <- pmIsSatisfiable delta tm_ct ty_cs strict_arg_tys-    pure $ fmap (ValVec (va:vva)) mb_sat--  set_provenance prov .-    force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>-      runMany (pmcheckI (p:ps) guards) inst_vsa---- LitVar-pmcheckHd (p@(PmLit l)) ps guards (PmVar x) (ValVec vva delta)-  = force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>-      mkUnion non_matched <$>-        case solveOneEq (delta_tm_cs delta) (mkPosEq x l) of-          Just tm_state -> pmcheckHdI p ps guards (PmLit l) $-                             ValVec vva (delta {delta_tm_cs = tm_state})-          Nothing       -> return mempty-  where-    us | Just tm_state <- solveOneEq (delta_tm_cs delta) (mkNegEq x l)-       = [ValVec (PmNLit x [l] : vva) (delta { delta_tm_cs = tm_state })]-       | otherwise = []--    non_matched = usimple us---- LitNLit-pmcheckHd (p@(PmLit l)) ps guards-          (PmNLit { pm_lit_id = x, pm_lit_not = lits }) (ValVec vva delta)-  | all (not . eqPmLit l) lits-  , Just tm_state <- solveOneEq (delta_tm_cs delta) (mkPosEq x l)-    -- Both guards check the same so it would be sufficient to have only-    -- the second one. Nevertheless, it is much cheaper to check whether-    -- the literal is in the list so we check it first, to avoid calling-    -- the term oracle (`solveOneEq`) if possible-  = mkUnion non_matched <$>-      pmcheckHdI p ps guards (PmLit l)-                (ValVec vva (delta { delta_tm_cs = tm_state }))-  | otherwise = return non_matched-  where-    us | Just tm_state <- solveOneEq (delta_tm_cs delta) (mkNegEq x l)-       = [ValVec (PmNLit x (l:lits) : vva) (delta { delta_tm_cs = tm_state })]-       | otherwise = []--    non_matched = usimple us---- ------------------------------------------------------------------------------- The following three can happen only in cases like #322 where constructors--- and overloaded literals appear in the same match. The general strategy is--- to replace the literal (positive/negative) by a variable and recurse. The--- fact that the variable is equal to the literal is recorded in `delta` so--- no information is lost---- LitCon-pmcheckHd (PmLit l) ps guards (va@(PmCon {})) (ValVec vva delta)-  = do y <- liftD $ mkPmId (pmPatType va)-       let tm_state = extendSubst y (PmExprLit l) (delta_tm_cs delta)-           delta'   = delta { delta_tm_cs = tm_state }-       pmcheckHdI (PmVar y) ps guards va (ValVec vva delta')---- ConLit-pmcheckHd (p@(PmCon {})) ps guards (PmLit l) (ValVec vva delta)-  = do y <- liftD $ mkPmId (pmPatType p)-       let tm_state = extendSubst y (PmExprLit l) (delta_tm_cs delta)-           delta'   = delta { delta_tm_cs = tm_state }-       pmcheckHdI p ps guards (PmVar y) (ValVec vva delta')---- ConNLit-pmcheckHd (p@(PmCon {})) ps guards (PmNLit { pm_lit_id = x }) vva-  = pmcheckHdI p ps guards (PmVar x) vva---- Impossible: handled by pmcheck-pmcheckHd (PmGrd {}) _ _ _ _ = panic "pmcheckHd: Guard"--{--Note [Coverage checking and existential tyvars]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-GHC's implementation of the pattern-match coverage algorithm (as described in-the GADTs Meet Their Match paper) must take some care to emit enough type-constraints when handling data constructors with exisentially quantified type-variables. To better explain what the challenge is, consider a constructor K-of the form:--  K @e_1 ... @e_m ev_1 ... ev_v ty_1 ... ty_n :: T u_1 ... u_p--Where:--* e_1, ..., e_m are the existentially bound type variables.-* ev_1, ..., ev_v are evidence variables, which may inhabit a dictionary type-  (e.g., Eq) or an equality constraint (e.g., e_1 ~ Int).-* ty_1, ..., ty_n are the types of K's fields.-* T u_1 ... u_p is the return type, where T is the data type constructor, and-  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 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,-but we don't want them to appear in the final PmCon, because then-calling (mkOneConFull K) for other pattern variables might reuse the same-existential tyvars, which is certainly wrong.--Previously, GHC's solution to this wrinkle was to always create fresh names-for the existential tyvars and put them into the PmCon. This works well for-many cases, but it can break down if you nest GADT pattern matches in just-the right way. For instance, consider the following program:--    data App f a where-      App :: f a -> App f (Maybe a)--    data Ty a where-      TBool :: Ty Bool-      TInt  :: Ty Int--    data T f a where-      C :: T Ty (Maybe Bool)--    foo :: T f a -> App f a -> ()-    foo C (App TBool) = ()--foo is a total program, but with the previous approach to handling existential-tyvars, GHC would mark foo's patterns as non-exhaustive.--When foo is desugared to Core, it looks roughly like so:--    foo @f @a (C co1 _co2) (App @a1 _co3 (TBool |> co1)) = ()--(Where `a1` is an existential tyvar.)--That, in turn, is processed by the coverage checker to become:--    foo @f @a (C co1 _co2) (App @a1 _co3 (pmvar123 :: f a1))-      | TBool <- pmvar123 |> co1-      = ()--Note that the type of pmvar123 is `f a1`—this will be important later.--Now, we proceed with coverage-checking as usual. When we come to the-ConVar case for App, we create a fresh variable `a2` to represent its-existential tyvar. At this point, we have the equality constraints-`(a ~ Maybe a2, a ~ Maybe Bool, f ~ Ty)` in scope.--However, when we check the guard, it will use the type of pmvar123, which is-`f a1`. Thus, when considering if pmvar123 can match the constructor TInt,-it will generate the constraint `a1 ~ Int`. This means our final set of-equality constraints would be:--    f  ~ Ty-    a  ~ Maybe Bool-    a  ~ Maybe a2-    a1 ~ Int--Which is satisfiable! Freshening the existential tyvar `a` to `a2` doomed us,-because GHC is unable to relate `a2` to `a1`, which really should be the same-tyvar.--Luckily, we can avoid this pitfall. Recall that the ConVar case was where we-generated a PmCon with too-fresh existentials. But after ConVar, we have the-ConCon case, which considers whether each constructor of a particular data type-can be matched on in a particular spot.--In the case of App, when we get to the ConCon case, we will compare our-original App PmCon (from the source program) to the App PmCon created from the-ConVar case. In the former PmCon, we have `a1` in hand, which is exactly the-existential tyvar we want! Thus, we can force `a1` to be the same as `a2` here-by emitting an additional `a1 ~ a2` constraint. Now our final set of equality-constraints will be:--    f  ~ Ty-    a  ~ Maybe Bool-    a  ~ Maybe a2-    a1 ~ Int-    a1 ~ a2--Which is unsatisfiable, as we desired, since we now have that-Int ~ a1 ~ a2 ~ Bool.--In general, App might have more than one constructor, in which case we-couldn't reuse the existential tyvar for App for a different constructor. This-means that we can only use this trick in ConCon when the constructors are the-same. But this is fine, since this is the only scenario where this situation-arises in the first place!--}---- ------------------------------------------------------------------------------- * Utilities for main checking--updateVsa :: (ValSetAbs -> ValSetAbs) -> (PartialResult -> PartialResult)-updateVsa f p@(PartialResult { presultUncovered = old })-  = p { presultUncovered = f old }----- | Initialise with default values for covering and divergent information.-usimple :: ValSetAbs -> PartialResult-usimple vsa = mempty { presultUncovered = vsa }---- | Take the tail of all value vector abstractions in the uncovered set-utail :: PartialResult -> PartialResult-utail = updateVsa upd-  where upd vsa = [ ValVec vva delta | ValVec (_:vva) delta <- vsa ]---- | Prepend a value abstraction to all value vector abstractions in the--- uncovered set-ucon :: ValAbs -> PartialResult -> PartialResult-ucon va = updateVsa upd-  where-    upd vsa = [ ValVec (va:vva) delta | ValVec vva delta <- vsa ]---- | Given a data constructor of arity `a` and an uncovered set containing--- value vector abstractions of length `(a+n)`, pass the first `n` value--- abstractions to the constructor (Hence, the resulting value vector--- abstractions will have length `n+1`)-kcon :: ConLike -> [Type] -> [TyVar] -> [EvVar]-     -> PartialResult -> PartialResult-kcon con arg_tys ex_tvs dicts-  = let n = conLikeArity con-        upd vsa =-          [ ValVec (va:vva) delta-          | ValVec vva' delta <- vsa-          , let (args, vva) = splitAt n vva'-          , let va = PmCon { pm_con_con     = con-                            , pm_con_arg_tys = arg_tys-                            , pm_con_tvs     = ex_tvs-                            , pm_con_dicts   = dicts-                            , pm_con_args    = args } ]-    in updateVsa upd---- | Get the union of two covered, uncovered and divergent value set--- abstractions. Since the covered and divergent sets are represented by a--- boolean, union means computing the logical or (at least one of the two is--- non-empty).--mkUnion :: PartialResult -> PartialResult -> PartialResult-mkUnion = mappend---- | Add a value vector abstraction to a value set abstraction (uncovered).-mkCons :: ValVec -> PartialResult -> PartialResult-mkCons vva = updateVsa (vva:)---- | Set the divergent set to not empty-forces :: PartialResult -> PartialResult-forces pres = pres { presultDivergent = Diverged }---- | Set the divergent set to non-empty if the flag is `True`-force_if :: Bool -> PartialResult -> PartialResult-force_if True  pres = forces pres-force_if False pres = pres--set_provenance :: Provenance -> PartialResult -> PartialResult-set_provenance prov pr = pr { presultProvenance = prov }---- ------------------------------------------------------------------------------- * Propagation of term constraints inwards when checking nested matches--{- Note [Type and Term Equality Propagation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When checking a match it would be great to have all type and term information-available so we can get more precise results. For this reason we have functions-`addDictsDs' and `addTmCsDs' in PmMonad that store in the environment type and-term constraints (respectively) as we go deeper.--The type constraints we propagate inwards are collected by `collectEvVarsPats'-in HsPat.hs. This handles bug #4139 ( see example-  https://ghc.haskell.org/trac/ghc/attachment/ticket/4139/GADTbug.hs )-where this is needed.--For term equalities we do less, we just generate equalities for HsCase. For-example we accurately give 2 redundancy warnings for the marked cases:--f :: [a] -> Bool-f x = case x of--  []    -> case x of        -- brings (x ~ []) in scope-             []    -> True-             (_:_) -> False -- can't happen--  (_:_) -> case x of        -- brings (x ~ (_:_)) in scope-             (_:_) -> True-             []    -> False -- can't happen--Functions `genCaseTmCs1' and `genCaseTmCs2' are responsible for generating-these constraints.--}---- | Generate equalities when checking a case expression:---     case x of { p1 -> e1; ... pn -> en }--- When we go deeper to check e.g. e1 we record two equalities:--- (x ~ y), where y is the initial uncovered when checking (p1; .. ; pn)--- and (x ~ p1).-genCaseTmCs2 :: Maybe (LHsExpr GhcTc) -- Scrutinee-             -> [Pat GhcTc]           -- LHS       (should have length 1)-             -> [Id]                  -- MatchVars (should have length 1)-             -> DsM (Bag SimpleEq)-genCaseTmCs2 Nothing _ _ = return emptyBag-genCaseTmCs2 (Just scr) [p] [var] = do-  fam_insts <- dsGetFamInstEnvs-  [e] <- map vaToPmExpr . coercePatVec <$> translatePat fam_insts p-  let scr_e = lhsExprToPmExpr scr-  return $ listToBag [(var, e), (var, scr_e)]-genCaseTmCs2 _ _ _ = panic "genCaseTmCs2: HsCase"---- | Generate a simple equality when checking a case expression:---     case x of { matches }--- When checking matches we record that (x ~ y) where y is the initial--- uncovered. All matches will have to satisfy this equality.-genCaseTmCs1 :: Maybe (LHsExpr GhcTc) -> [Id] -> Bag SimpleEq-genCaseTmCs1 Nothing     _    = emptyBag-genCaseTmCs1 (Just scr) [var] = unitBag (var, lhsExprToPmExpr scr)-genCaseTmCs1 _ _              = panic "genCaseTmCs1: HsCase"--{- Note [Literals in PmPat]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Instead of translating a literal to a variable accompanied with a guard, we-treat them like constructor patterns. The following example from-"./libraries/base/GHC/IO/Encoding.hs" shows why:--mkTextEncoding' :: CodingFailureMode -> String -> IO TextEncoding-mkTextEncoding' cfm enc = case [toUpper c | c <- enc, c /= '-'] of-    "UTF8"    -> return $ UTF8.mkUTF8 cfm-    "UTF16"   -> return $ UTF16.mkUTF16 cfm-    "UTF16LE" -> return $ UTF16.mkUTF16le cfm-    ...--Each clause gets translated to a list of variables with an equal number of-guards. For every guard we generate two cases (equals True/equals False) which-means that we generate 2^n cases to feed the oracle with, where n is the sum of-the length of all strings that appear in the patterns. For this particular-example this means over 2^40 cases. Instead, by representing them like with-constructor we get the following:-  1. We exploit the common prefix with our representation of VSAs-  2. We prune immediately non-reachable cases-     (e.g. False == (x == "U"), True == (x == "U"))--Note [Translating As Patterns]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Instead of translating x@p as:  x (p <- x)-we instead translate it as:     p (x <- coercePattern p)-for performance reasons. For example:--  f x@True  = 1-  f y@False = 2--Gives the following with the first translation:--  x |> {x == False, x == y, y == True}--If we use the second translation we get an empty set, independently of the-oracle. Since the pattern `p' may contain guard patterns though, it cannot be-used as an expression. That's why we call `coercePatVec' to drop the guard and-`vaToPmExpr' to transform the value abstraction to an expression in the-guard pattern (value abstractions are a subset of expressions). We keep the-guards in the first pattern `p' though.---%************************************************************************-%*                                                                      *-      Pretty printing of exhaustiveness/redundancy check warnings-%*                                                                      *-%************************************************************************--}---- | Check whether any part of pattern match checking is enabled (does not--- matter whether it is the redundancy check or the exhaustiveness check).-isAnyPmCheckEnabled :: DynFlags -> DsMatchContext -> Bool-isAnyPmCheckEnabled dflags (DsMatchContext kind _loc)-  = wopt Opt_WarnOverlappingPatterns dflags || exhaustive dflags kind--instance Outputable ValVec where-  ppr (ValVec vva delta)-    = let (residual_eqs, subst) = wrapUpTmState (delta_tm_cs delta)-          vector                = substInValAbs subst vva-      in  ppr_uncovered (vector, residual_eqs)---- | Apply a term substitution to a value vector abstraction. All VAs are--- transformed to PmExpr (used only before pretty printing).-substInValAbs :: PmVarEnv -> [ValAbs] -> [PmExpr]-substInValAbs subst = map (exprDeepLookup subst . vaToPmExpr)---- | Wrap up the term oracle's state once solving is complete. Drop any--- information about unhandled constraints (involving HsExprs) and flatten--- (height 1) the substitution.-wrapUpTmState :: TmState -> ([ComplexEq], PmVarEnv)-wrapUpTmState (residual, (_, subst)) = (residual, flattenPmVarEnv subst)---- | Issue all the warnings (coverage, exhaustiveness, inaccessibility)-dsPmWarn :: DynFlags -> DsMatchContext -> PmResult -> DsM ()-dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result-  = when (flag_i || flag_u) $ do-      let exists_r = flag_i && notNull redundant && onlyBuiltin-          exists_i = flag_i && notNull inaccessible && onlyBuiltin && not is_rec_upd-          exists_u = flag_u && (case uncovered of-                                  TypeOfUncovered   _ -> True-                                  UncoveredPatterns u -> notNull u)--      when exists_r $ forM_ redundant $ \(dL->L l q) -> do-        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)-                               (pprEqn q "is redundant"))-      when exists_i $ forM_ inaccessible $ \(dL->L l q) -> do-        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)-                               (pprEqn q "has inaccessible right hand side"))-      when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $-        case uncovered of-          TypeOfUncovered ty           -> warnEmptyCase ty-          UncoveredPatterns candidates -> pprEqns candidates-  where-    PmResult-      { pmresultProvenance = prov-      , pmresultRedundant = redundant-      , pmresultUncovered = uncovered-      , pmresultInaccessible = inaccessible } = pm_result--    flag_i = wopt Opt_WarnOverlappingPatterns dflags-    flag_u = exhaustive dflags kind-    flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind)--    is_rec_upd = case kind of { RecUpd -> True; _ -> False }-       -- See Note [Inaccessible warnings for record updates]--    onlyBuiltin = prov == FromBuiltin--    maxPatterns = maxUncoveredPatterns dflags--    -- Print a single clause (for redundant/with-inaccessible-rhs)-    pprEqn q txt = pp_context True ctx (text txt) $ \f -> ppr_eqn f kind q--    -- Print several clauses (for uncovered clauses)-    pprEqns qs = pp_context False ctx (text "are non-exhaustive") $ \_ ->-      case qs of -- See #11245-           [ValVec [] _]-                    -> text "Guards do not cover entire pattern space"-           _missing -> let us = map ppr qs-                       in  hang (text "Patterns not matched:") 4-                                (vcat (take maxPatterns us)-                                 $$ dots maxPatterns us)--    -- Print a type-annotated wildcard (for non-exhaustive `EmptyCase`s for-    -- which we only know the type and have no inhabitants at hand)-    warnEmptyCase ty = pp_context False ctx (text "are non-exhaustive") $ \_ ->-      hang (text "Patterns not matched:") 4 (underscore <+> dcolon <+> ppr ty)--{- Note [Inaccessible warnings for record updates]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (Trac #12957)-  data T a where-    T1 :: { x :: Int } -> T Bool-    T2 :: { x :: Int } -> T a-    T3 :: T a--  f :: T Char -> T a-  f r = r { x = 3 }--The desugarer will (conservatively generate a case for T1 even though-it's impossible:-  f r = case r of-          T1 x -> T1 3   -- Inaccessible branch-          T2 x -> T2 3-          _    -> error "Missing"--We don't want to warn about the inaccessible branch because the programmer-didn't put it there!  So we filter out the warning here.--}---- | Issue a warning when the predefined number of iterations is exceeded--- for the pattern match checker-warnPmIters :: DynFlags -> DsMatchContext -> DsM ()-warnPmIters dflags (DsMatchContext kind loc)-  = when (flag_i || flag_u) $ do-      iters <- maxPmCheckIterations <$> getDynFlags-      putSrcSpanDs loc (warnDs NoReason (msg iters))-  where-    ctxt   = pprMatchContext kind-    msg is = fsep [ text "Pattern match checker exceeded"-                  , parens (ppr is), text "iterations in", ctxt <> dot-                  , text "(Use -fmax-pmcheck-iterations=n"-                  , text "to set the maximum number of iterations to n)" ]--    flag_i = wopt Opt_WarnOverlappingPatterns dflags-    flag_u = exhaustive dflags kind--dots :: Int -> [a] -> SDoc-dots maxPatterns qs-    | qs `lengthExceeds` maxPatterns = text "..."-    | otherwise                      = empty---- | Check whether the exhaustiveness checker should run (exhaustiveness only)-exhaustive :: DynFlags -> HsMatchContext id -> Bool-exhaustive  dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag---- | Denotes whether an exhaustiveness check is supported, and if so,--- via which 'WarningFlag' it's controlled.--- Returns 'Nothing' if check is not supported.-exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag-exhaustiveWarningFlag (FunRhs {})   = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag CaseAlt       = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag IfAlt         = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag LambdaExpr    = Just Opt_WarnIncompleteUniPatterns-exhaustiveWarningFlag PatBindRhs    = Just Opt_WarnIncompleteUniPatterns-exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag ProcExpr      = Just Opt_WarnIncompleteUniPatterns-exhaustiveWarningFlag RecUpd        = Just Opt_WarnIncompletePatternsRecUpd-exhaustiveWarningFlag ThPatSplice   = Nothing-exhaustiveWarningFlag PatSyn        = Nothing-exhaustiveWarningFlag ThPatQuote    = Nothing-exhaustiveWarningFlag (StmtCtxt {}) = Nothing -- Don't warn about incomplete patterns-                                       -- in list comprehensions, pattern guards-                                       -- etc. They are often *supposed* to be-                                       -- incomplete---- True <==> singular-pp_context :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc-pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun-  = vcat [text txt <+> msg,-          sep [ text "In" <+> ppr_match <> char ':'-              , nest 4 (rest_of_msg_fun pref)]]-  where-    txt | singular  = "Pattern match"-        | otherwise = "Pattern match(es)"--    (ppr_match, pref)-        = case kind of-             FunRhs { mc_fun = (dL->L _ fun) }-                  -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)-             _    -> (pprMatchContext kind, \ pp -> pp)--ppr_pats :: HsMatchContext Name -> [Pat GhcTc] -> SDoc-ppr_pats kind pats-  = sep [sep (map ppr pats), matchSeparator kind, text "..."]--ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> [LPat GhcTc] -> SDoc-ppr_eqn prefixF kind eqn = prefixF (ppr_pats kind (map unLoc eqn))--ppr_constraint :: (SDoc,[PmLit]) -> SDoc-ppr_constraint (var, lits) = var <+> text "is not one of"-                                 <+> braces (pprWithCommas ppr lits)--ppr_uncovered :: ([PmExpr], [ComplexEq]) -> SDoc-ppr_uncovered (expr_vec, complex)-  | null cs   = fsep vec -- there are no literal constraints-  | otherwise = hang (fsep vec) 4 $-                  text "where" <+> vcat (map ppr_constraint cs)-  where-    sdoc_vec = mapM pprPmExprWithParens expr_vec-    (vec,cs) = runPmPprM sdoc_vec (filterComplex complex)--{- Note [Representation of Term Equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the paper, term constraints always take the form (x ~ e). Of course, a more-general constraint of the form (e1 ~ e1) can always be transformed to an-equivalent set of the former constraints, by introducing a fresh, intermediate-variable: { y ~ e1, y ~ e1 }. Yet, implementing this representation gave rise-to #11160 (incredibly bad performance for literal pattern matching). Two are-the main sources of this problem (the actual problem is how these two interact-with each other):--1. Pattern matching on literals generates twice as many constraints as needed.-   Consider the following (tests/ghci/should_run/ghcirun004):--    foo :: Int -> Int-    foo 1    = 0-    ...-    foo 5000 = 4999--   The covered and uncovered set *should* look like:-     U0 = { x |> {} }--     C1  = { 1  |> { x ~ 1 } }-     U1  = { x  |> { False ~ (x ~ 1) } }-     ...-     C10 = { 10 |> { False ~ (x ~ 1), .., False ~ (x ~ 9), x ~ 10 } }-     U10 = { x  |> { False ~ (x ~ 1), .., False ~ (x ~ 9), False ~ (x ~ 10) } }-     ...--     If we replace { False ~ (x ~ 1) } with { y ~ False, y ~ (x ~ 1) }-     we get twice as many constraints. Also note that half of them are just the-     substitution [x |-> False].--2. The term oracle (`tmOracle` in deSugar/TmOracle) uses equalities of the form-   (x ~ e) as substitutions [x |-> e]. More specifically, function-   `extendSubstAndSolve` applies such substitutions in the residual constraints-   and partitions them in the affected and non-affected ones, which are the new-   worklist. Essentially, this gives quadradic behaviour on the number of the-   residual constraints. (This would not be the case if the term oracle used-   mutable variables but, since we use it to handle disjunctions on value set-   abstractions (`Union` case), we chose a pure, incremental interface).--Now the problem becomes apparent (e.g. for clause 300):-  * Set U300 contains 300 substituting constraints [y_i |-> False] and 300-    constraints that we know that will not reduce (stay in the worklist).-  * To check for consistency, we apply the substituting constraints ONE BY ONE-    (since `tmOracle` is called incrementally, it does not have all of them-    available at once). Hence, we go through the (non-progressing) constraints-    over and over, achieving over-quadradic behaviour.--If instead we allow constraints of the form (e ~ e),-  * All uncovered sets Ui contain no substituting constraints and i-    non-progressing constraints of the form (False ~ (x ~ lit)) so the oracle-    behaves linearly.-  * All covered sets Ci contain exactly (i-1) non-progressing constraints and-    a single substituting constraint. So the term oracle goes through the-    constraints only once.--The performance improvement becomes even more important when more arguments are-involved.--}---- Debugging Infrastructre--tracePm :: String -> SDoc -> PmM ()-tracePm herald doc = liftD $ tracePmD herald doc---tracePmD :: String -> SDoc -> DsM ()-tracePmD herald doc = do-  dflags <- getDynFlags-  printer <- mkPrintUnqualifiedDs-  liftIO $ dumpIfSet_dyn_printer printer dflags-            Opt_D_dump_ec_trace (text herald $$ (nest 2 doc))---pprPmPatDebug :: PmPat a -> SDoc-pprPmPatDebug (PmCon cc _arg_tys _con_tvs _con_dicts con_args)-  = hsep [text "PmCon", ppr cc, hsep (map pprPmPatDebug con_args)]-pprPmPatDebug (PmVar vid) = text "PmVar" <+> ppr vid-pprPmPatDebug (PmLit li)  = text "PmLit" <+> ppr li-pprPmPatDebug (PmNLit i nl) = text "PmNLit" <+> ppr i <+> ppr nl-pprPmPatDebug (PmGrd pv ge) = text "PmGrd" <+> hsep (map pprPmPatDebug pv)-                                           <+> ppr ge--pprPatVec :: PatVec -> SDoc-pprPatVec ps = hang (text "Pattern:") 2-                (brackets $ sep-                  $ punctuate (comma <> char '\n') (map pprPmPatDebug ps))--pprValAbs :: [ValAbs] -> SDoc-pprValAbs ps = hang (text "ValAbs:") 2-                (brackets $ sep-                  $ punctuate (comma) (map pprPmPatDebug ps))--pprValVecDebug :: ValVec -> SDoc-pprValVecDebug (ValVec vas _d) = text "ValVec" <+>-                                  parens (pprValAbs vas)
compiler/deSugar/Coverage.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE NondecreasingIndentation, RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveFunctor #-}  module Coverage (addTicksToBinds, hpcInitCode) where @@ -17,7 +18,7 @@ import ByteCodeTypes import GHC.Stack.CCS import Type-import HsSyn+import GHC.Hs import Module import Outputable import DynFlags@@ -49,6 +50,7 @@ import Trace.Hpc.Mix import Trace.Hpc.Util +import qualified Data.ByteString as BS import Data.Map (Map) import qualified Data.Map as Map @@ -111,7 +113,7 @@       dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" (pprLHsBinds binds1) -     return (binds1, HpcInfo tickCount hashNo, modBreaks)+     return (binds1, HpcInfo tickCount hashNo, Just modBreaks)    | otherwise = return (binds, emptyHpcInfo False, Nothing) @@ -119,7 +121,7 @@ guessSourceFile binds orig_file =      -- Try look for a file generated from a .hsc file to a      -- .hs file, by peeking ahead.-     let top_pos = catMaybes $ foldrBag (\ (dL->L pos _) rest ->+     let top_pos = catMaybes $ foldr (\ (dL->L pos _) rest ->                                  srcSpanFileName_maybe pos : rest) [] binds      in      case top_pos of@@ -128,23 +130,23 @@         _ -> orig_file  -mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO (Maybe ModBreaks)+mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks mkModBreaks hsc_env mod count entries-  | breakpointsEnabled (hsc_dflags hsc_env) = do+  | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do     breakArray <- GHCi.newBreakArray hsc_env (length entries)     ccs <- mkCCSArray hsc_env mod count entries     let            locsTicks  = listArray (0,count-1) [ span  | (span,_,_,_)  <- entries ]            varsTicks  = listArray (0,count-1) [ vars  | (_,_,vars,_)  <- entries ]            declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]-    return $ Just $ emptyModBreaks+    return emptyModBreaks                        { modBreaks_flags = breakArray                        , modBreaks_locs  = locsTicks                        , modBreaks_vars  = varsTicks                        , modBreaks_decls = declsTicks                        , modBreaks_ccs   = ccs                        }-  | otherwise = return Nothing+  | otherwise = return emptyModBreaks  mkCCSArray   :: HscEnv -> Module -> Int -> [MixEntry_]@@ -325,7 +327,7 @@    where    -- a binding is a simple pattern binding if it is a funbind with    -- zero patterns-   isSimplePatBind :: HsBind a -> Bool+   isSimplePatBind :: HsBind GhcTc -> Bool    isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0  -- TODO: Revisit this@@ -638,7 +640,7 @@ addTickTupArg (dL->L l (Present x e))  = do { e' <- addTickLHsExpr e                                             ; return (cL l (Present x e')) } addTickTupArg (dL->L l (Missing ty)) = return (cL l (Missing ty))-addTickTupArg (dL->L _ (XTupArg _)) = panic "addTickTupArg"+addTickTupArg (dL->L _ (XTupArg nec)) = noExtCon nec addTickTupArg _  = panic "addTickTupArg: Impossible Match" -- due to #15884  @@ -648,7 +650,7 @@   let isOneOfMany = matchesOneOfMany matches   matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches   return $ mg { mg_alts = cL l matches' }-addTickMatchGroup _ (XMatchGroup _) = panic "addTickMatchGroup"+addTickMatchGroup _ (XMatchGroup nec) = noExtCon nec  addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)              -> TM (Match GhcTc (LHsExpr GhcTc))@@ -657,7 +659,7 @@   bindLocals (collectPatsBinders pats) $ do     gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs     return $ match { m_grhss = gRHSs' }-addTickMatch _ _ (XMatch _) = panic "addTickMatch"+addTickMatch _ _ (XMatch nec) = noExtCon nec  addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)              -> TM (GRHSs GhcTc (LHsExpr GhcTc))@@ -668,7 +670,7 @@     return $ GRHSs x guarded' (cL l local_binds')   where     binders = collectLocalBinders local_binds-addTickGRHSs _ _ (XGRHSs _) = panic "addTickGRHSs"+addTickGRHSs _ _ (XGRHSs nec) = noExtCon nec  addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)             -> TM (GRHS GhcTc (LHsExpr GhcTc))@@ -676,7 +678,7 @@   (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts                         (addTickGRHSBody isOneOfMany isLambda expr)   return $ GRHS x stmts' expr'-addTickGRHS _ _ (XGRHS _) = panic "addTickGRHS"+addTickGRHS _ _ (XGRHS nec) = noExtCon nec  addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickGRHSBody isOneOfMany isLambda expr@(dL->L pos e0) = do@@ -755,7 +757,7 @@        ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'                       , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } -addTickStmt _ (XStmtLR _) = panic "addTickStmt"+addTickStmt _ (XStmtLR nec) = noExtCon nec  addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e@@ -767,17 +769,18 @@ addTickApplicativeArg isGuard (op, arg) =   liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)  where-  addTickArg (ApplicativeArgOne x pat expr isBody) =+  addTickArg (ApplicativeArgOne x pat expr isBody fail) =     (ApplicativeArgOne x)       <$> addTickLPat pat       <*> addTickLHsExpr expr       <*> pure isBody+      <*> addTickSyntaxExpr hpcSrcSpan fail   addTickArg (ApplicativeArgMany x stmts ret pat) =     (ApplicativeArgMany x)       <$> addTickLStmts isGuard stmts       <*> (unLoc <$> addTickLHsExpr (cL hpcSrcSpan ret))       <*> addTickLPat pat-  addTickArg (XApplicativeArg _) = panic "addTickApplicativeArg"+  addTickArg (XApplicativeArg nec) = noExtCon nec  addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc                       -> TM (ParStmtBlock GhcTc GhcTc)@@ -786,7 +789,7 @@         (addTickLStmts isGuard stmts)         (return ids)         (addTickSyntaxExpr hpcSrcSpan returnExpr)-addTickStmtAndBinders _ (XParStmtBlock{}) = panic "addTickStmtAndBinders"+addTickStmtAndBinders _ (XParStmtBlock nec) = noExtCon nec  addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc) addTickHsLocalBinds (HsValBinds x binds) =@@ -839,7 +842,7 @@         liftM2 HsCmdTop                 (return x)                 (addTickLHsCmd cmd)-addTickHsCmdTop (XCmdTop{}) = panic "addTickHsCmdTop"+addTickHsCmdTop (XCmdTop nec) = noExtCon nec  addTickLHsCmd ::  LHsCmd GhcTc -> TM (LHsCmd GhcTc) addTickLHsCmd (dL->L pos c0) = do@@ -895,7 +898,7 @@ addTickHsCmd (HsCmdWrap x w cmd)   = liftM2 (HsCmdWrap x) (return w) (addTickHsCmd cmd) -addTickHsCmd e@(XCmd {})  = pprPanic "addTickHsCmd" (ppr e)+addTickHsCmd (XCmd nec) = noExtCon nec  -- Others should never happen in a command context. --addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)@@ -905,14 +908,14 @@ addTickCmdMatchGroup mg@(MG { mg_alts = (dL->L l matches) }) = do   matches' <- mapM (liftL addTickCmdMatch) matches   return $ mg { mg_alts = cL l matches' }-addTickCmdMatchGroup (XMatchGroup _) = panic "addTickCmdMatchGroup"+addTickCmdMatchGroup (XMatchGroup nec) = noExtCon nec  addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) =   bindLocals (collectPatsBinders pats) $ do     gRHSs' <- addTickCmdGRHSs gRHSs     return $ match { m_grhss = gRHSs' }-addTickCmdMatch (XMatch _) = panic "addTickCmdMatch"+addTickCmdMatch (XMatch nec) = noExtCon nec  addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) addTickCmdGRHSs (GRHSs x guarded (dL->L l local_binds)) = do@@ -922,7 +925,7 @@     return $ GRHSs x guarded' (cL l local_binds')   where     binders = collectLocalBinders local_binds-addTickCmdGRHSs (XGRHSs _) = panic "addTickCmdGRHSs"+addTickCmdGRHSs (XGRHSs nec) = noExtCon nec  addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc)) -- The *guards* are *not* Cmds, although the body is@@ -931,7 +934,7 @@   = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)                                    stmts (addTickLHsCmd cmd)        ; return $ GRHS x stmts' expr' }-addTickCmdGRHS (XGRHS _) = panic "addTickCmdGRHS"+addTickCmdGRHS (XGRHS nec) = noExtCon nec  addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)]                  -> TM [LStmt GhcTc (LHsCmd GhcTc)]@@ -978,8 +981,8 @@                       , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } addTickCmdStmt ApplicativeStmt{} =   panic "ToDo: addTickCmdStmt ApplicativeLastStmt"-addTickCmdStmt XStmtLR{} =-  panic "addTickCmdStmt XStmtLR"+addTickCmdStmt (XStmtLR nec) =+  noExtCon nec  -- Others should never happen in a command context. addTickCmdStmt stmt  = pprPanic "addTickHsCmd" (ppr stmt)@@ -1038,7 +1041,7 @@  coveragePasses :: DynFlags -> [TickishType] coveragePasses dflags =-    ifa (breakpointsEnabled dflags)          Breakpoints $+    ifa (hscTarget dflags == HscInterpreted) Breakpoints $     ifa (gopt Opt_Hpc dflags)                HpcTicks $     ifa (gopt Opt_SccProfilingOn dflags &&          profAuto dflags /= NoProfAuto)      ProfNotes $@@ -1046,10 +1049,6 @@   where ifa f x xs | f         = x:xs                    | otherwise = xs --- | Should we produce 'Breakpoint' ticks?-breakpointsEnabled :: DynFlags -> Bool-breakpointsEnabled dflags = hscTarget dflags == HscInterpreted- -- | Tickishs that only make sense when their source code location -- refers to the current file. This might not always be true due to -- LINE pragmas in the code - which would confuse at least HPC.@@ -1073,13 +1072,11 @@ --   to filter additions to the latter.  This gives us complete control --   over what free variables we track. -data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }+newtype TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }+    deriving (Functor)         -- a combination of a state monad (TickTransState) and a writer         -- monad (FreeVars). -instance Functor TM where-    fmap = liftM- instance Applicative TM where     pure a = TM $ \ _env st -> (a,noFVs,st)     (<*>) = ap@@ -1179,7 +1176,7 @@     (fvs, e) <- getFreeVars m     env <- getEnv     tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)-    return (cL pos (HsTick noExt tickish (cL pos e)))+    return (cL pos (HsTick noExtField tickish (cL pos e)))   ) (do     e <- m     return (cL pos e)@@ -1266,8 +1263,8 @@       c = tickBoxCount st       mes = mixEntries st   in-     ( cL pos $ HsTick noExt (HpcTick (this_mod env) c)-          $ cL pos $ HsBinTick noExt (c+1) (c+2) e+     ( cL pos $ HsTick noExtField (HpcTick (this_mod env) c)+          $ cL pos $ HsBinTick noExtField (c+1) (c+2) e    -- notice that F and T are reversed,    -- because we are building the list in    -- reverse...@@ -1296,9 +1293,9 @@   where         matchCount (dL->L _ (Match { m_grhss = GRHSs _ grhss _ }))           = length grhss-        matchCount (dL->L _ (Match { m_grhss = XGRHSs _ }))-          = panic "matchesOneOfMany"-        matchCount (dL->L _ (XMatch _)) = panic "matchesOneOfMany"+        matchCount (dL->L _ (Match { m_grhss = XGRHSs nec }))+          = noExtCon nec+        matchCount (dL->L _ (XMatch nec)) = noExtCon nec         matchCount _ = panic "matchCount: Impossible Match" -- due to #15884  type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)@@ -1356,9 +1353,9 @@   where     tickboxes = ppr (mkHpcTicksLabel $ this_mod) -    module_name  = hcat (map (text.charToC) $+    module_name  = hcat (map (text.charToC) $ BS.unpack $                          bytesFS (moduleNameFS (Module.moduleName this_mod)))-    package_name = hcat (map (text.charToC) $+    package_name = hcat (map (text.charToC) $ BS.unpack $                          bytesFS (unitIdFS  (moduleUnitId this_mod)))     full_name_str        | moduleUnitId this_mod == mainUnitId
compiler/deSugar/Desugar.hs view
@@ -15,14 +15,14 @@     deSugar, deSugarExpr     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import DsUsage import DynFlags import HscTypes-import HsSyn+import GHC.Hs import TcRnTypes import TcRnMonad  ( finalSafeMode, fixSafeInstances ) import TcRnDriver ( runTcInteractive )@@ -114,7 +114,7 @@    = do { let dflags = hsc_dflags hsc_env              print_unqual = mkPrintUnqualified dflags rdr_env-        ; withTiming (pure dflags)+        ; withTiming dflags                      (text "Desugar"<+>brackets (ppr mod))                      (const ()) $      do { -- Desugar the program@@ -412,7 +412,7 @@          ; return (Just rule)         } } }-dsRule (dL->L _ (XRuleDecl _)) = panic "dsRule"+dsRule (dL->L _ (XRuleDecl nec)) = noExtCon nec dsRule _ = panic "dsRule: Impossible Match" -- due to #15884  warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()@@ -533,7 +533,7 @@  Class methods have a built-in RULE to select the method from the dictionary, so you can't change the phase on this.  That makes id very dubious to-match on class methods in RULE lhs's.   See Trac #10595.   I'm not happy+match on class methods in RULE lhs's.   See #10595.   I'm not happy about this. For example in Control.Arrow we have  {-# RULES "compose/arr"   forall f g .
compiler/deSugar/DsArrows.hs view
@@ -12,7 +12,7 @@  module DsArrows ( dsProcExpr ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -20,11 +20,11 @@ import DsUtils import DsMonad -import HsSyn    hiding (collectPatBinders, collectPatsBinders,+import GHC.Hs   hiding (collectPatBinders, collectPatsBinders,                         collectLStmtsBinders, collectLStmtBinders,                         collectStmtBinders ) import TcHsSyn-import qualified HsUtils+import qualified GHC.Hs.Utils as HsUtils  -- NB: The desugarer, which straddles the source and Core worlds, sometimes --     needs to see source types (newtypes etc), and sometimes not@@ -50,7 +50,6 @@ import BasicTypes import PrelNames import Outputable-import Bag import VarSet import SrcLoc import ListSetOps( assocMaybe )@@ -63,7 +62,7 @@     }  mkCmdEnv :: CmdSyntaxTable GhcTc -> DsM ([CoreBind], DsCmdEnv)--- See Note [CmdSyntaxTable] in HsExpr+-- See Note [CmdSyntaxTable] in GHC.Hs.Expr mkCmdEnv tc_meths   = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths @@ -592,11 +591,11 @@     left_con <- dsLookupDataCon leftDataConName     right_con <- dsLookupDataCon rightDataConName     let-        left_id  = HsConLikeOut noExt (RealDataCon left_con)-        right_id = HsConLikeOut noExt (RealDataCon right_con)-        left_expr  ty1 ty2 e = noLoc $ HsApp noExt+        left_id  = HsConLikeOut noExtField (RealDataCon left_con)+        right_id = HsConLikeOut noExtField (RealDataCon right_con)+        left_expr  ty1 ty2 e = noLoc $ HsApp noExtField                            (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e-        right_expr ty1 ty2 e = noLoc $ HsApp noExt+        right_expr ty1 ty2 e = noLoc $ HsApp noExtField                            (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e          -- Prefix each tuple with a distinct series of Left's and Right's,@@ -616,7 +615,7 @@         (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches         in_ty = envStackType env_ids stack_ty -    core_body <- dsExpr (HsCase noExt exp+    core_body <- dsExpr (HsCase noExtField exp                          (MG { mg_alts = cL l matches'                              , mg_ext = MatchGroupTc arg_tys sum_ty                              , mg_origin = origin }))@@ -1167,7 +1166,7 @@   = let         (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss     in-    (leaves', cL loc (match { m_ext = noExt, m_grhss = GRHSs x grhss' binds }))+    (leaves', cL loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds })) replaceLeavesMatch _ _ _ = panic "replaceLeavesMatch"  replaceLeavesGRHS@@ -1192,10 +1191,10 @@     fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs  {--Note [Dictionary binders in ConPatOut] See also same Note in HsUtils+Note [Dictionary binders in ConPatOut] See also same Note in GHC.Hs.Utils ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The following functions to collect value variables from patterns are-copied from HsUtils, with one change: we also collect the dictionary+copied from GHC.Hs.Utils, with one change: we also collect the dictionary bindings (pat_binds) from ConPatOut.  We need them for cases like  h :: Arrow a => Int -> a (Int,Int) Int@@ -1209,7 +1208,7 @@  Here p77 is a local binding for the (+) operation. -See comments in HsUtils for why the other version does not include+See comments in GHC.Hs.Utils for why the other version does not include these bindings. -} @@ -1251,7 +1250,7 @@     go p@(XPat {})                = pprPanic "collectl/go" (ppr p)  collectEvBinders :: TcEvBinds -> [Id]-collectEvBinders (EvBinds bs)   = foldrBag add_ev_bndr [] bs+collectEvBinders (EvBinds bs)   = foldr add_ev_bndr [] bs collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"  add_ev_bndr :: EvBind -> [Id] -> [Id]
compiler/deSugar/DsBinds.hs view
@@ -19,7 +19,7 @@                  dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule   ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -29,9 +29,9 @@ import DsMonad import DsGRHSs import DsUtils-import Check ( checkGuardMatches )+import GHC.HsToCore.PmCheck ( needToRunPmCheck, addTyCsDs, checkGuardMatches ) -import HsSyn            -- lots of things+import GHC.Hs           -- lots of things import CoreSyn          -- lots of things import CoreOpt          ( simpleOptExpr ) import OccurAnal        ( occurAnalyseExpr )@@ -41,6 +41,7 @@ import CoreUnfold import CoreFVs import Digraph+import Predicate  import PrelNames import TyCon@@ -186,11 +187,15 @@                           , abs_exports = exports                           , abs_ev_binds = ev_binds                           , abs_binds = binds, abs_sig = has_sig })-  = do { ds_binds <- addDictsDs (listToBag dicts) $-                     dsLHsBinds binds-                         -- addDictsDs: push type constraints deeper-                         --             for inner pattern match check-                         -- See Check, Note [Type and Term Equality Propagation]+  = do { ds_binds <- applyWhen (needToRunPmCheck dflags FromSource)+                               -- FromSource might not be accurate, but at worst+                               -- we do superfluous calls to the pattern match+                               -- oracle.+                               -- addTyCsDs: push type constraints deeper+                               --            for inner pattern match check+                               -- See Check, Note [Type and Term Equality Propagation]+                               (addTyCsDs (listToBag dicts))+                               (dsLHsBinds binds)         ; ds_ev_binds <- dsTcEvBinds_s ev_binds @@ -198,7 +203,7 @@        ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig }  dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"-dsHsBind _ (XHsBindsLR{}) = panic "dsHsBind: XHsBindsLR"+dsHsBind _ (XHsBindsLR nec) = noExtCon nec   -----------------------@@ -258,7 +263,7 @@                    ; return (makeCorePair dflags global                                           (isDefaultMethod prags)                                           0 (core_wrap (Var local))) }-             mk_bind (XABExport _) = panic "dsAbsBinds"+             mk_bind (XABExport nec) = noExtCon nec        ; main_binds <- mapM mk_bind exports         ; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) }@@ -303,7 +308,7 @@                            -- the user written (local) function.  The global                            -- Id is just the selector.  Hmm.                      ; return ((global', rhs) : fromOL spec_binds) }-             mk_bind (XABExport _) = panic "dsAbsBinds"+             mk_bind (XABExport nec) = noExtCon nec         ; export_binds_s <- mapM mk_bind (exports ++ extra_exports) @@ -351,7 +356,7 @@     mk_export local =       do global <- newSysLocalDs                      (exprType (mkLams tyvars (mkLams dicts (Var local))))-         return (ABE { abe_ext   = noExt+         return (ABE { abe_ext   = noExtField                      , abe_poly  = global                      , abe_mono  = local                      , abe_wrap  = WpHole@@ -530,7 +535,7 @@  Note [Desugar Strict binds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~-See https://ghc.haskell.org/trac/ghc/wiki/StrictPragma+See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma  Desugaring strict variable bindings looks as follows (core below ==>) @@ -598,7 +603,7 @@   in tm `seq` <body>  -See https://ghc.haskell.org/trac/ghc/wiki/StrictPragma for a more+See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma for a more detailed explanation of the desugaring of strict bindings.  Note [Strict binds checks]@@ -614,9 +619,9 @@   x :: Char   (# True, x #) = blah -is *not* an unlifted bind. Unlifted binds are detected by HsUtils.isUnliftedHsBind.+is *not* an unlifted bind. Unlifted binds are detected by GHC.Hs.Utils.isUnliftedHsBind. -Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedHsBind.+Define a "banged bind" to have a top-level bang. Detected by GHC.Hs.Pat.isBangedHsBind. Define a "strict bind" to be either an unlifted bind or a banged bind.  The restrictions are:@@ -776,7 +781,7 @@  We might want to specialise 'f' so that we in turn specialise '$wf'. We can't even /name/ '$wf' in the source code, so we can't specialise-it even if we wanted to.  Trac #10721 is a case in point.+it even if we wanted to.  #10721 is a case in point.  Note [Activation pragmas for SPECIALISE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -792,7 +797,7 @@ * Activation of RULE: from SPECIALISE pragma (if activation given)                       otherwise from f's inline pragma -This is not obvious (see Trac #5237)!+This is not obvious (see #5237)!  Examples      Rule activation   Inline prag on spec'd fn ---------------------------------------------------------------------@@ -875,7 +880,7 @@                            , not (v `elemVarSet` orig_bndr_set)                            , not (v == fn_id) ]          -- fn_id: do not quantify over the function itself, which may-         -- itself be a dictionary (in pathological cases, Trac #10251)+         -- itself be a dictionary (in pathological cases, #10251)     decompose (Var fn_id) args       | not (fn_id `elemVarSet` orig_bndr_set)@@ -1018,7 +1023,7 @@      NB3: In the common case of a non-overloaded, but perhaps-polymorphic          specialisation, we don't need to bind *any* dictionaries for use-         in the RHS. For example (Trac #8331)+         in the RHS. For example (#8331)              {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-}              useAbstractMonad :: MonadAbstractIOST m => m Int          Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code@@ -1026,7 +1031,7 @@              RULE forall s (d :: MonadAbstractIOST (ReaderT s)).                 useAbstractMonad (ReaderT s) d = $suseAbstractMonad s -   Trac #8848 is a good example of where there are some interesting+   #8848 is a good example of where there are some interesting    dictionary bindings to discard.  The drop_dicts algorithm is based on these observations:@@ -1068,12 +1073,6 @@        otherwise we don't match when given an argument like           augment (\a. h a a) (build h) -Note [Matching seqId]-~~~~~~~~~~~~~~~~~~~-The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack-and this code turns it back into an application of seq!-See Note [Rules for seq] in MkId for the details.- Note [Unused spec binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -1164,7 +1163,7 @@   = map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges)   where     edges :: [ Node EvVar (EvVar,CoreExpr) ]-    edges = foldrBag ((:) . mk_node) [] ds_binds+    edges = foldr ((:) . mk_node) [] ds_binds      mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr)     mk_node b@(var, rhs)
+ compiler/deSugar/DsBinds.hs-boot view
@@ -0,0 +1,6 @@+module DsBinds where+import DsMonad     ( DsM )+import CoreSyn     ( CoreExpr )+import TcEvidence (HsWrapper)++dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
compiler/deSugar/DsCCall.hs view
@@ -15,7 +15,7 @@         , resultWrapper         ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"   import GhcPrelude@@ -120,7 +120,7 @@     mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args   where     arg_tys = map exprType val_args-    body_ty = (mkFunTys arg_tys res_ty)+    body_ty = (mkVisFunTys arg_tys res_ty)     tyvars  = tyCoVarsOfTypeWellScoped body_ty     ty      = mkInvForAllTys tyvars body_ty     the_fcall_id = mkFCallId dflags uniq the_fcall ty@@ -251,7 +251,7 @@                                              [the_alt]                                      ] -        ; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }+        ; return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap) }  boxResult result_ty   = do -- It isn't IO, so do unsafePerformIO@@ -263,7 +263,7 @@                                            ccall_res_ty                                            (coreAltType the_alt)                                            [the_alt]-       return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)+       return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap)   where     return_result _ [ans] = ans     return_result _ _     = panic "return_result: expected single result"
compiler/deSugar/DsExpr.hs view
@@ -13,7 +13,7 @@ module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds               , dsValBinds, dsLit, dsSyntaxExpr ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -25,19 +25,18 @@ import DsUtils import DsArrows import DsMonad-import Check ( checkGuardMatches )+import GHC.HsToCore.PmCheck ( checkGuardMatches ) import Name import NameEnv import FamInstEnv( topNormaliseType ) import DsMeta-import HsSyn+import GHC.Hs  -- NB: The desugarer, which straddles the source and Core worlds, sometimes --     needs to see source types import TcType import TcEvidence import TcRnMonad-import TcHsSyn import Type import CoreSyn import CoreUtils@@ -50,6 +49,7 @@ import Module import ConLike import DataCon+import TyCoPpr( pprWithTYPE ) import TysWiredIn import PrelNames import BasicTypes@@ -98,7 +98,7 @@       = do e' <- dsLExpr e            return (Let (NonRec n e') body)     ds_ip_bind _ _ = panic "dsIPBinds"-dsIPBinds (XHsIPBinds _) _ = panic "dsIPBinds"+dsIPBinds (XHsIPBinds nec) _ = noExtCon nec  ------------------------- -- caller sets location@@ -122,7 +122,7 @@             -- f x = let p@(Ptr y) = ... in ...             -- Here the binding for 'p' is polymorphic, but does             -- not mix with an unlifted binding for 'y'.  You should-            -- use a bang pattern.  Trac #6078.+            -- use a bang pattern.  #6078.      else do { when (looksLazyPatBind bind) $               warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind)@@ -187,7 +187,7 @@                , abs_binds = lbinds }) body   = do { let body1 = foldr bind_export body exports              bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b-       ; body2 <- foldlBagM (\body lbind -> dsUnliftedBind (unLoc lbind) body)+       ; body2 <- foldlM (\body lbind -> dsUnliftedBind (unLoc lbind) body)                             body1 lbinds        ; ds_binds <- dsTcEvBinds_s ev_binds        ; return (mkCoreLets ds_binds body2) }@@ -331,47 +331,26 @@ That 'g' in the 'in' part is an evidence variable, and when converting to core it must become a CO. --Note [Desugaring operator sections]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-At first it looks as if we can convert--    (expr `op`)--naively to--    \x -> op expr x+Operator sections.  At first it looks as if we can convert+\begin{verbatim}+        (expr op)+\end{verbatim}+to+\begin{verbatim}+        \x -> op expr x+\end{verbatim}  But no!  expr might be a redex, and we can lose laziness badly this way.  Consider--    map (expr `op`) xs--for example. If expr were a redex then eta-expanding naively would-result in multiple evaluations where the user might only have expected one.--So we convert instead to--    let y = expr in \x -> op y x--Also, note that we must do this for both right and (perhaps surprisingly) left-sections. Why are left sections necessary? Consider the program (found in #18151),--    seq (True `undefined`) ()--according to the Haskell Report this should reduce to () (as it specifies-desugaring via eta expansion). However, if we fail to eta expand we will rather-bottom. Consequently, we must eta expand even in the case of a left section.--If `expr` is actually just a variable, say, then the simplifier-will inline `y`, eliminating the redundant `let`.--Note that this works even in the case that `expr` is unlifted. In this case-bindNonRec will automatically do the right thing, giving us:--    case expr of y -> (\x -> op y x)--See #18151.+\begin{verbatim}+        map (expr op) xs+\end{verbatim}+for example.  So we convert instead to+\begin{verbatim}+        let y = expr in \x -> op y x+\end{verbatim}+If \tr{expr} is actually just a variable, say, then the simplifier+will sort it out. -}  ds_expr _ e@(OpApp _ e1 op e2)@@ -380,35 +359,17 @@        ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])                       (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') } --- dsExpr (SectionL op expr)  ===  (expr `op`)  ~>  \y -> op expr y------ See Note [Desugaring operator sections].--- N.B. this also must handle postfix operator sections due to -XPostfixOperators.-ds_expr _ e@(SectionL _ expr op) = do-    core_op <- dsLExpr op-    x_core <- dsLExpr expr-    case splitFunTys (exprType core_op) of-      -- Binary operator section-      (x_ty:y_ty:_, _) -> do-        dsWhenNoErrs-          (mapM newSysLocalDsNoLP [x_ty, y_ty])-          (\[x_id, y_id] ->-            bindNonRec x_id x_core-            $ Lam y_id (mkCoreAppsDs (text "sectionl" <+> ppr e)-                                     core_op [Var x_id, Var y_id]))--      -- Postfix operator section-      (_:_, _) -> do-        return $ mkCoreAppDs (text "sectionl" <+> ppr e) core_op x_core--      _ -> pprPanic "dsExpr(SectionL)" (ppr e)+ds_expr _ (SectionL _ expr op)       -- Desugar (e !) to ((!) e)+  = do { op' <- dsLExpr op+       ; dsWhenNoErrs (dsLExprNoLP expr)+                      (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') } --- dsExpr (SectionR op expr)  === (`op` expr)  ~>  \x -> op x expr------ See Note [Desugaring operator sections].+-- dsLExpr (SectionR op expr)   -- \ x -> op x expr ds_expr _ e@(SectionR _ op expr) = do     core_op <- dsLExpr op+    -- for the type of x, we need the type of op's 2nd argument     let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)+        -- See comment with SectionL     y_core <- dsLExpr expr     dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty])                  (\[x_id, y_id] -> bindNonRec y_id y_core $@@ -432,6 +393,7 @@                 -- The reverse is because foldM goes left-to-right                       (\(lam_vars, args) -> mkCoreLams lam_vars $                                             mkCoreTupBoxity boxity args) }+                        -- See Note [Don't flatten tuples from HsSyn] in MkCore  ds_expr _ (ExplicitSum types alt arity expr)   = do { dsWhenNoErrs (dsLExprNoLP expr)@@ -490,7 +452,7 @@   | otherwise   = do { match_result <- liftM (foldr1 combineMatchResults)                                (mapM (dsGRHS IfAlt res_ty) alts)-       ; checkGuardMatches IfAlt (GRHSs noExt alts (noLoc emptyLocalBinds))+       ; checkGuardMatches IfAlt (GRHSs noExtField alts (noLoc emptyLocalBinds))        ; error_expr   <- mkErrorExpr        ; extractMatchResult match_result error_expr }   where@@ -661,7 +623,7 @@       -- Clone the Id in the HsRecField, because its Name is that       -- of the record selector, and we must not make that a local binder       -- else we shadow other uses of the record selector-      -- Hence 'lcl_id'.  Cf Trac #2735+      -- Hence 'lcl_id'.  Cf #2735     ds_field (dL->L _ rec_field)       = do { rhs <- dsLExpr (hsRecFieldArg rec_field)            ; let fld_id = unLoc (hsRecUpdFieldId rec_field)@@ -702,7 +664,7 @@                  mk_val_arg fl pat_arg_id                      = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) -                 inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExt con)+                 inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExtField con)                         -- Reconstruct with the WrapId so that unpacking happens                  wrap = mkWpEvVarApps theta_vars                                <.>                         dict_req_wrap                                           <.>@@ -791,15 +753,9 @@  -- HsSyn constructs that just shouldn't be here: ds_expr _ (HsBracket     {})  = panic "dsExpr:HsBracket"-ds_expr _ (HsArrApp      {})  = panic "dsExpr:HsArrApp"-ds_expr _ (HsArrForm     {})  = panic "dsExpr:HsArrForm"-ds_expr _ (EWildPat      {})  = panic "dsExpr:EWildPat"-ds_expr _ (EAsPat        {})  = panic "dsExpr:EAsPat"-ds_expr _ (EViewPat      {})  = panic "dsExpr:EViewPat"-ds_expr _ (ELazyPat      {})  = panic "dsExpr:ELazyPat" ds_expr _ (HsDo          {})  = panic "dsExpr:HsDo" ds_expr _ (HsRecFld      {})  = panic "dsExpr:HsRecFld"-ds_expr _ (XExpr         {})  = panic "dsExpr: XExpr"+ds_expr _ (XExpr nec)         = noExtCon nec   ------------------------------@@ -968,25 +924,26 @@              let                (pats, rhss) = unzip (map (do_arg . snd) args) -               do_arg (ApplicativeArgOne _ pat expr _) =-                 (pat, dsLExpr expr)+               do_arg (ApplicativeArgOne _ pat expr _ fail_op) =+                 ((pat, fail_op), dsLExpr expr)                do_arg (ApplicativeArgMany _ stmts ret pat) =-                 (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))-               do_arg (XApplicativeArg _) = panic "dsDo"--               arg_tys = map hsLPatType pats+                 ((pat, noSyntaxExpr), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))+               do_arg (XApplicativeArg nec) = noExtCon nec             ; rhss' <- sequence rhss -           ; let body' = noLoc $ HsDo body_ty DoExpr (noLoc stmts)+           ; body' <- dsLExpr $ noLoc $ HsDo body_ty DoExpr (noLoc stmts) -           ; let fun = cL noSrcSpan $ HsLam noExt $-                   MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats-                                                       body']-                      , mg_ext = MatchGroupTc arg_tys body_ty-                      , mg_origin = Generated }+           ; let match_args (pat, fail_op) (vs,body)+                   = do { var   <- selectSimpleMatchVarL pat+                        ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat+                                   body_ty (cantFailMatchResult body)+                        ; match_code <- handle_failure pat match fail_op+                        ; return (var:vs, match_code)+                        } -           ; fun' <- dsLExpr fun+           ; (vars, body) <- foldrM match_args ([],body') pats+           ; let fun' = mkLams vars body            ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r]            ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss')            ; case mb_join of@@ -1012,13 +969,13 @@         later_pats   = rec_tup_pats         rets         = map noLoc rec_rets         mfix_app     = nlHsSyntaxApps mfix_op [mfix_arg]-        mfix_arg     = noLoc $ HsLam noExt+        mfix_arg     = noLoc $ HsLam noExtField                            (MG { mg_alts = noLoc [mkSimpleMatch                                                     LambdaExpr                                                     [mfix_pat] body]                                , mg_ext = MatchGroupTc [tup_ty] body_ty                                , mg_origin = Generated })-        mfix_pat     = noLoc $ LazyPat noExt $ mkBigLHsPatTupId rec_tup_pats+        mfix_pat     = noLoc $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats         body         = noLoc $ HsDo body_ty                                 DoExpr (noLoc (rec_stmts ++ [ret_stmt]))         ret_app      = nlHsSyntaxApps return_op [mkBigLHsTupId rets]@@ -1029,7 +986,7 @@      go _ (ParStmt   {}) _ = panic "dsDo ParStmt"     go _ (TransStmt {}) _ = panic "dsDo TransStmt"-    go _ (XStmtLR   {}) _ = panic "dsDo XStmtLR"+    go _ (XStmtLR nec)  _ = noExtCon nec  handle_failure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr     -- In a do expression, pattern-match failure just calls@@ -1136,7 +1093,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We cannot have levity polymorphic function arguments. See Note [Levity polymorphism invariants] in CoreSyn. But we *can* have-functions that take levity polymorphism arguments, as long as these+functions that take levity polymorphic arguments, as long as these functions are eta-reduced. (See #12708 for an example.)  However, we absolutely cannot do this for functions that have no@@ -1207,7 +1164,11 @@  levPolyPrimopErr :: Id -> Type -> [Type] -> DsM () levPolyPrimopErr primop ty bad_tys-  = errDs $ vcat [ hang (text "Cannot use primitive with levity-polymorphic arguments:")-                      2 (ppr primop <+> dcolon <+> pprWithTYPE ty)-                 , hang (text "Levity-polymorphic arguments:")-                      2 (vcat (map (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t)) bad_tys)) ]+  = errDs $ vcat+    [ hang (text "Cannot use function with levity-polymorphic arguments:")+         2 (ppr primop <+> dcolon <+> pprWithTYPE ty)+    , hang (text "Levity-polymorphic arguments:")+         2 $ vcat $ map+           (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t))+           bad_tys+    ]
compiler/deSugar/DsExpr.hs-boot view
@@ -1,8 +1,8 @@ module DsExpr where-import HsSyn       ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr )+import GHC.Hs      ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr ) import DsMonad     ( DsM ) import CoreSyn     ( CoreExpr )-import HsExtension ( GhcTc)+import GHC.Hs.Extension ( GhcTc)  dsExpr  :: HsExpr GhcTc -> DsM CoreExpr dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
compiler/deSugar/DsForeign.hs view
@@ -13,7 +13,7 @@  module DsForeign ( dsForeigns ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h" import GhcPrelude  import TcRnMonad        -- temp@@ -23,7 +23,7 @@ import DsCCall import DsMonad -import HsSyn+import GHC.Hs import DataCon import CoreUnfold import Id@@ -49,8 +49,7 @@ import Outputable import FastString import DynFlags-import Platform-import Config+import GHC.Platform import OrdList import Pair import Util@@ -113,7 +112,7 @@                               (dL->L _ (CExportStatic _ ext_nm cconv)) _ }) = do       (h, c, _, _) <- dsFExport id co ext_nm cconv False       return (h, c, [id], [])-   do_decl (XForeignDecl _) = panic "dsForeigns'"+   do_decl (XForeignDecl nec) = noExtCon nec  {- ************************************************************************@@ -271,7 +270,7 @@                   return (fcall, empty)     let         -- Build the worker-        worker_ty     = mkForAllTys tv_bndrs (mkFunTys (map idType work_arg_ids) ccall_result_ty)+        worker_ty     = mkForAllTys tv_bndrs (mkVisFunTys (map idType work_arg_ids) ccall_result_ty)         tvs           = map binderVar tv_bndrs         the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty         work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)@@ -431,7 +430,7 @@     stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName     let         stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]-        export_ty     = mkFunTy stable_ptr_ty arg_ty+        export_ty     = mkVisFunTy stable_ptr_ty arg_ty     bindIOId <- dsLookupGlobalId bindIOName     stbl_value <- newSysLocalDs stable_ptr_ty     (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True@@ -542,7 +541,7 @@         | otherwise = text ('a':show n)    -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled-  libffi = cLibFFI && isNothing maybe_target+  libffi = platformMisc_libFFI (platformMisc dflags) && isNothing maybe_target    type_string       -- libffi needs to know the result type too:
compiler/deSugar/DsGRHSs.hs view
@@ -11,19 +11,21 @@  module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import {-# SOURCE #-} DsExpr  ( dsLExpr, dsLocalBinds ) import {-# SOURCE #-} Match   ( matchSinglePatVar ) -import HsSyn+import GHC.Hs import MkCore import CoreSyn import CoreUtils (bindNonRec) -import Check (genCaseTmCs2)+import BasicTypes (Origin(FromSource))+import DynFlags+import GHC.HsToCore.PmCheck (needToRunPmCheck, addTyCsDs, addPatTmCs, addScrutTmCs) import DsMonad import DsUtils import Type   ( Type )@@ -64,13 +66,13 @@              match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1                              -- NB: nested dsLet inside matchResult        ; return match_result2 }-dsGRHSs _ (XGRHSs _) _ = panic "dsGRHSs"+dsGRHSs _ (XGRHSs nec) _ = noExtCon nec  dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc)        -> DsM MatchResult dsGRHS hs_ctx rhs_ty (dL->L _ (GRHS _ guards rhs))   = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty-dsGRHS _ _ (dL->L _ (XGRHS _)) = panic "dsGRHS"+dsGRHS _ _ (dL->L _ (XGRHS nec)) = noExtCon nec dsGRHS _ _ _ = panic "dsGRHS: Impossible Match" -- due to #15884  {-@@ -122,11 +124,16 @@     let upat = unLoc pat         dicts = collectEvVarsPat upat     match_var <- selectMatchVar upat-    tm_cs <- genCaseTmCs2 (Just bind_rhs) [upat] [match_var]-    match_result <- addDictsDs dicts $-                    addTmCsDs tm_cs  $-                      -- See Note [Type and Term Equality Propagation] in Check-                    matchGuards stmts ctx rhs rhs_ty++    dflags <- getDynFlags+    match_result <-+      -- See Note [Type and Term Equality Propagation] in Check+      applyWhen (needToRunPmCheck dflags FromSource)+                -- FromSource might not be accurate, but at worst+                -- we do superfluous calls to the pattern match+                -- oracle.+                (addTyCsDs dicts . addScrutTmCs (Just bind_rhs) [match_var] . addPatTmCs [upat] [match_var])+                (matchGuards stmts ctx rhs rhs_ty)     core_rhs <- dsLExpr bind_rhs     match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty                                        match_result@@ -138,8 +145,8 @@ matchGuards (RecStmt   {} : _) _ _ _ = panic "matchGuards RecStmt" matchGuards (ApplicativeStmt {} : _) _ _ _ =   panic "matchGuards ApplicativeLastStmt"-matchGuards (XStmtLR {} : _) _ _ _ =-  panic "matchGuards XStmtLR"+matchGuards (XStmtLR nec : _) _ _ _ =+  noExtCon nec  {- Should {\em fail} if @e@ returns @D@
compiler/deSugar/DsListComp.hs view
@@ -12,13 +12,13 @@  module DsListComp ( dsListComp, dsMonadComp ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr ) -import HsSyn+import GHC.Hs import TcHsSyn import CoreSyn import MkCore@@ -91,7 +91,7 @@        ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty         ; return (expr, bndrs_tuple_type) }-dsInnerListComp (XParStmtBlock{}) = panic "dsInnerListComp"+dsInnerListComp (XParStmtBlock nec) = noExtCon nec  -- This function factors out commonality between the desugaring strategies for GroupStmt. -- Given such a statement it gives you back an expression representing how to compute the transformed@@ -107,7 +107,7 @@         to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys      -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders-    (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExt stmts+    (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExtField stmts                                                         from_bndrs noSyntaxExpr)      -- Work out what arguments should be supplied to that expression: i.e. is an extraction@@ -267,8 +267,8 @@ deListComp (ApplicativeStmt {} : _) _ =   panic "deListComp ApplicativeStmt" -deListComp (XStmtLR {} : _) _ =-  panic "deListComp XStmtLR"+deListComp (XStmtLR nec : _) _ =+  noExtCon nec  deBindComp :: OutPat GhcTc            -> CoreExpr@@ -282,7 +282,7 @@     let u2_ty = hsLPatType pat      let res_ty = exprType core_list2-        h_ty   = u1_ty `mkFunTy` res_ty+        h_ty   = u1_ty `mkVisFunTy` res_ty         -- no levity polymorphism here, as list comprehensions don't work        -- with RebindableSyntax. NB: These are *not* monad comps.@@ -364,8 +364,8 @@ dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt" dfListComp _ _ (ApplicativeStmt {} : _) =   panic "dfListComp ApplicativeStmt"-dfListComp _ _ (XStmtLR {} : _) =-  panic "dfListComp XStmtLR"+dfListComp _ _ (XStmtLR nec : _) =+  noExtCon nec  dfBindComp :: Id -> Id             -- 'c' and 'n'            -> (LPat GhcTc, CoreExpr)@@ -425,7 +425,7 @@     elt_tuple_ty      = mkBigCoreTupTy elt_tys     elt_tuple_list_ty = mkListTy elt_tuple_ty -    zip_fn_ty         = mkFunTys elt_list_tys elt_tuple_list_ty+    zip_fn_ty         = mkVisFunTys elt_list_tys elt_tuple_list_ty      mk_case (as, a', as') rest           = Case (Var as) as elt_tuple_list_ty@@ -473,7 +473,7 @@     elt_list_tys       = map mkListTy elt_tys     elt_list_tuple_ty  = mkBigCoreTupTy elt_list_tys -    unzip_fn_ty        = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty+    unzip_fn_ty        = elt_tuple_list_ty `mkVisFunTy` elt_list_tuple_ty      mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail @@ -596,7 +596,7 @@     ds_inner (ParStmtBlock _ stmts bndrs return_op)        = do { exp <- dsInnerMonadComp stmts bndrs return_op             ; return (exp, mkBigCoreVarTupTy bndrs) }-    ds_inner (XParStmtBlock{}) = panic "dsMcStmt"+    ds_inner (XParStmtBlock nec) = noExtCon nec  dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt) @@ -655,7 +655,7 @@                  -> DsM CoreExpr dsInnerMonadComp stmts bndrs ret_op   = dsMcStmts (stmts ++-                 [noLoc (LastStmt noExt (mkBigLHsVarTupId bndrs) False ret_op)])+                 [noLoc (LastStmt noExtField (mkBigLHsVarTupId bndrs) False ret_op)])   -- The `unzip` function for `GroupStmt` in a monad comprehensions
compiler/deSugar/DsMeta.hs view
@@ -19,7 +19,7 @@  module DsMeta( dsBracket ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -30,7 +30,7 @@  import qualified Language.Haskell.TH as TH -import HsSyn+import GHC.Hs import PrelNames -- To avoid clashes with DsMeta.varName we must make a local alias for -- OccName.varName we do this by removing varName from the import of@@ -43,7 +43,6 @@ import Name hiding( isVarOcc, isTcOcc, varName, tcName ) import THNames import NameEnv-import NameSet import TcType import TyCon import TysWiredIn@@ -85,7 +84,7 @@     do_brack (DecBrG _ gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }     do_brack (DecBrL {})   = panic "dsBracket: unexpected DecBrL"     do_brack (TExpBr _ e)  = do { MkC e1  <- repLE e     ; return e1 }-    do_brack (XBracket {}) = panic "dsBracket: unexpected XBracket"+    do_brack (XBracket nec) = noExtCon nec  {- -------------- Examples -------------------- @@ -141,6 +140,7 @@                      ; _        <- mapM no_splice splcds                      ; tycl_ds  <- mapM repTyClD (tyClGroupTyClDecls tyclds)                      ; role_ds  <- mapM repRoleD (concatMap group_roles tyclds)+                     ; kisig_ds <- mapM repKiSigD (concatMap group_kisigs tyclds)                      ; inst_ds  <- mapM repInstD instds                      ; deriv_ds <- mapM repStandaloneDerivD derivds                      ; fix_ds   <- mapM repFixD fixds@@ -156,6 +156,7 @@                         -- more needed                      ;  return (de_loc $ sort_by_loc $                                 val_ds ++ catMaybes tycl_ds ++ role_ds+                                       ++ kisig_ds                                        ++ (concat fix_ds)                                        ++ inst_ds ++ rule_ds ++ for_ds                                        ++ ann_ds ++ deriv_ds) }) ;@@ -179,7 +180,7 @@     no_warn _ = panic "repTopDs"     no_doc (dL->L loc _)       = notHandledL loc "Haddock documentation" empty-repTopDs (XHsGroup _) = panic "repTopDs"+repTopDs (XHsGroup nec) = noExtCon nec  hsScopedTvBinders :: HsValBinds GhcRn -> [Name] -- See Note [Scoped type variables in bindings]@@ -207,10 +208,10 @@       --    here 'k' scopes too       | HsIB { hsib_ext = implicit_vars              , hsib_body = hs_ty } <- sig-      , (explicit_vars, _) <- splitLHsForAllTy hs_ty-      = implicit_vars ++ map hsLTyVarName explicit_vars-    get_scoped_tvs_from_sig (XHsImplicitBndrs _)-      = panic "get_scoped_tvs_from_sig"+      , (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty+      = implicit_vars ++ hsLTyVarNames explicit_vars+    get_scoped_tvs_from_sig (XHsImplicitBndrs nec)+      = noExtCon nec  {- Notes @@ -329,7 +330,7 @@               ; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds               ; fds1   <- repLFunDeps fds               ; ats1   <- repFamilyDecls ats-              ; atds1  <- repAssocTyFamDefaults atds+              ; atds1  <- mapM (repAssocTyFamDefaultD . unLoc) atds               ; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs_binds)               ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1               ; wrapGenSyms ss decls2 }@@ -349,6 +350,13 @@ repRoleD _ = panic "repRoleD"  -------------------------+repKiSigD :: LStandaloneKindSig GhcRn -> DsM (SrcSpan, Core TH.DecQ)+repKiSigD (dL->L loc kisig) =+  case kisig of+    StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v+    XStandaloneKindSig nec -> noExtCon nec++------------------------- repDataDefn :: Core TH.Name             -> Either (Core [TH.TyVarBndrQ])                         -- the repTyClD case@@ -375,7 +383,7 @@                                ; repData cxt1 tc opts ksig' cons1                                          derivs1 }        }-repDataDefn _ _ (XHsDataDefn _) = panic "repDataDefn"+repDataDefn _ _ (XHsDataDefn nec) = noExtCon nec  repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ]            -> LHsType GhcRn@@ -392,9 +400,7 @@                                           , fdInjectivityAnn = injectivity }))   = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]        ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn-             mkHsQTvs tvs = HsQTvs { hsq_ext = HsQTvsRn-                                                { hsq_implicit = []-                                                , hsq_dependent = emptyNameSet }+             mkHsQTvs tvs = HsQTvs { hsq_ext = []                                    , hsq_explicit = tvs }              resTyVar = case resultSig of                      TyVarSig _ bndr -> mkHsQTvs [bndr]@@ -428,7 +434,7 @@                                           ; repKindSig ki' } repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr                                           ; repTyVarSig bndr' }-repFamilyResultSig (XFamilyResultSig _) = panic "repFamilyResultSig"+repFamilyResultSig (XFamilyResultSig nec) = noExtCon nec  -- | Represent result signature using a Maybe Kind. Used with data families, -- where the result signature can be either missing or a kind but never a named@@ -457,35 +463,8 @@ repFamilyDecls :: [LFamilyDecl GhcRn] -> DsM [Core TH.DecQ] repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds) -repAssocTyFamDefaults :: [LTyFamDefltEqn GhcRn] -> DsM [Core TH.DecQ]-repAssocTyFamDefaults = mapM rep_deflt-  where-     -- very like repTyFamEqn, but different in the details-    rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ)-    rep_deflt (dL->L _ (FamEqn { feqn_tycon = tc-                               , feqn_bndrs = bndrs-                               , feqn_pats  = tys-                               , feqn_fixity = fixity-                               , feqn_rhs   = rhs }))-      = addTyClTyVarBinds tys $ \ _ ->-        do { tc1  <- lookupLOcc tc-           ; no_bndrs <- ASSERT( isNothing bndrs )-                         coreNothingList tyVarBndrQTyConName-           ; tys1 <- repLTys (hsLTyVarBndrsToTypes tys)-           ; lhs <- case fixity of-                      Prefix -> do { head_ty <- repNamedTyCon tc1-                                   ; repTapps head_ty tys1 }-                      Infix -> do { (t1:t2:args) <- checkTys tys1-                                  ; head_ty <- repTInfix t1 tc1 t2-                                  ; repTapps head_ty args }-           ; rhs1 <- repLTy rhs-           ; eqn1 <- repTySynEqn no_bndrs lhs rhs1-           ; repTySynInst eqn1 }-    rep_deflt _ = panic "repAssocTyFamDefaults"--    checkTys :: [Core TH.TypeQ] -> DsM [Core TH.TypeQ]-    checkTys tys@(_:_:_) = return tys-    checkTys _ = panic "repAssocTyFamDefaults:checkTys"+repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> DsM (Core TH.DecQ)+repAssocTyFamDefaultD = repTyFamInstD  ------------------------- -- represent fundeps@@ -527,7 +506,7 @@             -- But we do NOT bring the binders of 'binds' into scope             -- because they are properly regarded as occurrences             -- For example, the method names should be bound to-            -- the selector Ids, not to fresh names (Trac #5410)+            -- the selector Ids, not to fresh names (#5410)             --             do { cxt1     <- repLContext cxt                ; inst_ty1 <- repLTy inst_ty@@ -541,7 +520,7 @@                ; wrapGenSyms ss decls2 }  where    (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty-repClsInstD (XClsInstDecl _) = panic "repClsInstD"+repClsInstD (XClsInstDecl nec) = noExtCon nec  repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repStandaloneDerivD (dL->L loc (DerivDecl { deriv_strategy = strat@@ -569,9 +548,7 @@                                        , feqn_fixity = fixity                                        , feqn_rhs  = rhs }})   = do { tc <- lookupLOcc tc_name     -- See note [Binders and occurrences]-       ; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn-                               { hsq_implicit = var_names-                               , hsq_dependent = emptyNameSet }   -- Yuk+       ; let hs_tvs = HsQTvs { hsq_ext = var_names                              , hsq_explicit = fromMaybe [] mb_bndrs }        ; addTyClTyVarBinds hs_tvs $ \ _ ->          do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName@@ -588,8 +565,8 @@      where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn]            checkTys tys@(HsValArg _:HsValArg _:_) = return tys            checkTys _ = panic "repTyFamEqn:checkTys"-repTyFamEqn (XHsImplicitBndrs _) = panic "repTyFamEqn"-repTyFamEqn (HsIB _ (XFamEqn _)) = panic "repTyFamEqn"+repTyFamEqn (XHsImplicitBndrs nec) = noExtCon nec+repTyFamEqn (HsIB _ (XFamEqn nec)) = noExtCon nec  repTyArgs :: DsM (Core TH.TypeQ) -> [LHsTypeArg GhcRn] -> DsM (Core TH.TypeQ) repTyArgs f [] = f@@ -610,9 +587,7 @@                                              , feqn_fixity = fixity                                              , feqn_rhs   = defn }})})   = do { tc <- lookupLOcc tc_name         -- See note [Binders and occurrences]-       ; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn-                                 { hsq_implicit = var_names-                                 , hsq_dependent = emptyNameSet }   -- Yuk+       ; let hs_tvs = HsQTvs { hsq_ext = var_names                              , hsq_explicit = fromMaybe [] mb_bndrs }        ; addTyClTyVarBinds hs_tvs $ \ _ ->          do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName@@ -630,10 +605,10 @@             checkTys tys@(HsValArg _: HsValArg _: _) = return tys             checkTys _ = panic "repDataFamInstD:checkTys" -repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs _))-  = panic "repDataFamInstD"-repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn _)))-  = panic "repDataFamInstD"+repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs nec))+  = noExtCon nec+repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn nec)))+  = noExtCon nec  repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ) repForD (dL->L loc (ForeignImport { fd_name = name, fd_sig_ty = typ@@ -728,7 +703,7 @@   = panic "ruleBndrNames" ruleBndrNames (dL->L _ (RuleBndrSig _ _ (XHsWildCardBndrs _)))   = panic "ruleBndrNames"-ruleBndrNames (dL->L _ (XRuleBndr _)) = panic "ruleBndrNames"+ruleBndrNames (dL->L _ (XRuleBndr nec)) = noExtCon nec ruleBndrNames _ = panic "ruleBndrNames: Impossible Match" -- due to #15884  repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ)@@ -904,7 +879,7 @@ -- and Note [Don't quantify implicit type variables in quotes] rep_ty_sig mk_sig loc sig_ty nm   | HsIB { hsib_body = hs_ty } <- sig_ty-  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty+  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis hs_ty   = do { nm1 <- lookupLOcc nm        ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)                                      ; repTyVarBndrWithKind tv name }@@ -921,7 +896,7 @@                        else repTForall th_explicit_tvs th_ctxt th_ty        ; sig     <- repProto mk_sig nm1 ty1        ; return (loc, sig) }-rep_ty_sig _ _ (XHsImplicitBndrs _) _ = panic "rep_ty_sig"+rep_ty_sig _ _ (XHsImplicitBndrs nec) _ = noExtCon nec  rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name                   -> DsM (SrcSpan, Core TH.DecQ)@@ -950,7 +925,7 @@                        repTForall th_exis th_provs th_ty        ; sig      <- repProto patSynSigDName nm1 ty1        ; return (loc, sig) }-rep_patsyn_ty_sig _ (XHsImplicitBndrs _) _ = panic "rep_patsyn_ty_sig"+rep_patsyn_ty_sig _ (XHsImplicitBndrs nec) _ = noExtCon nec  rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name               -> DsM (SrcSpan, Core TH.DecQ)@@ -1037,7 +1012,7 @@                 -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))  -- action in the ext env                 -> DsM (Core (TH.Q a)) addHsTyVarBinds exp_tvs thing_inside-  = do { fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs)+  = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs)        ; term <- addBinds fresh_exp_names $                  do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr                                      (exp_tvs `zip` fresh_exp_names)@@ -1052,13 +1027,13 @@ -- gensym a list of type variables and enter them into the meta environment; -- the computations passed as the second argument is executed in that extended -- meta environment and gets the *new* names on Core-level as an argument-addTyVarBinds (HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = imp_tvs}+addTyVarBinds (HsQTvs { hsq_ext = imp_tvs                       , hsq_explicit = exp_tvs })               thing_inside   = addSimpleTyVarBinds imp_tvs $     addHsTyVarBinds exp_tvs $     thing_inside-addTyVarBinds (XLHsQTyVars _) _ = panic "addTyVarBinds"+addTyVarBinds (XLHsQTyVars nec) _ = noExtCon nec  addTyClTyVarBinds :: LHsQTyVars GhcRn                   -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))@@ -1120,7 +1095,7 @@ repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ) repHsSigType (HsIB { hsib_ext = implicit_tvs                    , hsib_body = body })-  | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body+  | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis body   = addSimpleTyVarBinds implicit_tvs $       -- See Note [Don't quantify implicit type variables in quotes]     addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs ->@@ -1129,12 +1104,12 @@        ; if null explicit_tvs && null (unLoc ctxt)          then return th_ty          else repTForall th_explicit_tvs th_ctxt th_ty }-repHsSigType (XHsImplicitBndrs _) = panic "repHsSigType"+repHsSigType (XHsImplicitBndrs nec) = noExtCon nec  repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ) repHsSigWcType (HsWC { hswc_body = sig1 })   = repHsSigType sig1-repHsSigWcType (XHsWildCardBndrs _) = panic "repHsSigWcType"+repHsSigWcType (XHsWildCardBndrs nec) = noExtCon nec  -- yield the representation of a list of types repLTys :: [LHsType GhcRn] -> DsM [Core TH.TypeQ]@@ -1144,18 +1119,29 @@ repLTy :: LHsType GhcRn -> DsM (Core TH.TypeQ) repLTy ty = repTy (unLoc ty) -repForall :: HsType GhcRn -> DsM (Core TH.TypeQ)--- Arg of repForall is always HsForAllTy or HsQualTy-repForall ty- | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)+-- Desugar a type headed by an invisible forall (e.g., @forall a. a@) or+-- a context (e.g., @Show a => a@) into a ForallT from L.H.TH.Syntax.+-- In other words, the argument to this function is always an+-- @HsForAllTy ForallInvis@ or @HsQualTy@.+-- Types headed by visible foralls (which are desugared to ForallVisT) are+-- handled separately in repTy.+repForallT :: HsType GhcRn -> DsM (Core TH.TypeQ)+repForallT ty+ | (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLoc ty)  = addHsTyVarBinds tvs $ \bndrs ->    do { ctxt1  <- repLContext ctxt-      ; ty1    <- repLTy tau-      ; repTForall bndrs ctxt1 ty1 }+      ; tau1   <- repLTy tau+      ; repTForall bndrs ctxt1 tau1 -- forall a. C a => {...}+      }  repTy :: HsType GhcRn -> DsM (Core TH.TypeQ)-repTy ty@(HsForAllTy {}) = repForall ty-repTy ty@(HsQualTy {})   = repForall ty+repTy ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = body }) =+  case fvf of+    ForallInvis -> repForallT ty+    ForallVis   -> addHsTyVarBinds tvs $ \bndrs ->+                   do body1 <- repLTy body+                      repTForallVis bndrs body1+repTy ty@(HsQualTy {}) = repForallT ty  repTy (HsTyVar _ _ (dL->L _ n))   | isLiftedTypeKindTyConName n       = repTStar@@ -1256,7 +1242,7 @@ repSplice (HsQuasiQuote _ n _ _ _)  = rep_splice n repSplice e@(HsSpliced {})          = pprPanic "repSplice" (ppr e) repSplice e@(HsSplicedT {})         = pprPanic "repSpliceT" (ppr e)-repSplice e@(XSplice {})            = pprPanic "repSplice" (ppr e)+repSplice (XSplice nec)             = noExtCon nec  rep_splice :: Name -> DsM (Core a) rep_splice splice_name@@ -1293,7 +1279,7 @@ repE (HsOverLabel _ _ s) = repOverLabel s  repE e@(HsRecFld _ f) = case f of-  Unambiguous x _ -> repE (HsVar noExt (noLoc x))+  Unambiguous x _ -> repE (HsVar noExtField (noLoc x))   Ambiguous{}     -> notHandled "Ambiguous record selectors" (ppr e)   XAmbiguousFieldOcc{} -> notHandled "XAmbiguous record selectors" (ppr e) @@ -1363,13 +1349,21 @@   = notHandled "monad comprehension and [: :]" (ppr e)  repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }-repE e@(ExplicitTuple _ es boxed)-  | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)-  | isBoxed boxed = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es]-                       ; repTup xs }-  | otherwise     = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es]-                       ; repUnboxedTup xs }+repE (ExplicitTuple _ es boxity) =+  let tupArgToCoreExp :: LHsTupArg GhcRn -> DsM (Core (Maybe TH.ExpQ))+      tupArgToCoreExp a+        | L _ (Present _ e) <- dL a = do { e' <- repLE e+                                         ; coreJust expQTyConName e' }+        | otherwise = coreNothing expQTyConName +  in do { args <- mapM tupArgToCoreExp es+        ; expQTy <- lookupType expQTyConName+        ; let maybeExpQTy = mkTyConApp maybeTyCon [expQTy]+              listArg = coreList' maybeExpQTy args+        ; if isBoxed boxity+          then repTup listArg+          else repUnboxedTup listArg }+ repE (ExplicitSum _ alt arity e)  = do { e1 <- repLE e       ; repUnboxedSum e1 alt arity }@@ -1444,7 +1438,7 @@        gs <- repGuards guards      ; clause <- repClause ps1 gs ds      ; wrapGenSyms (ss1++ss2) clause }}}-repClauseTup (dL->L _ (Match _ _ _ (XGRHSs _))) = panic "repClauseTup"+repClauseTup (dL->L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec repClauseTup _ = panic "repClauseTup"  repGuards ::  [LGRHS GhcRn (LHsExpr GhcRn)] ->  DsM (Core TH.BodyQ)@@ -1551,7 +1545,7 @@        do { (ss1, zs) <- repSts (map unLoc stmts)           ; zs1 <- coreList stmtQTyConName zs           ; return (ss1, zs1) }-     rep_stmt_block (XParStmtBlock{}) = panic "repSts"+     rep_stmt_block (XParStmtBlock nec) = noExtCon nec repSts [LastStmt _ e _ _]   = do { e2 <- repLE e        ; z <- repNoBindSt e2@@ -1661,7 +1655,7 @@         ; ans <- repFun fn' (nonEmptyCoreList ms1)         ; return (loc, ans) } -rep_bind (dL->L _ (FunBind { fun_matches = XMatchGroup _ })) = panic "rep_bind"+rep_bind (dL->L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec  rep_bind (dL->L loc (PatBind { pat_lhs = pat                              , pat_rhs = GRHSs _ guards (dL->L _ wheres) }))@@ -1671,7 +1665,7 @@         ; ans  <- repVal patcore guardcore wherecore         ; ans' <- wrapGenSyms ss ans         ; return (loc, ans') }-rep_bind (dL->L _ (PatBind _ _ (XGRHSs _) _)) = panic "rep_bind"+rep_bind (dL->L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec  rep_bind (dL->L _ (VarBind { var_id = v, var_rhs = e}))  =   do { v' <- lookupBinder v@@ -1721,9 +1715,9 @@     wrapGenArgSyms (RecCon _) _  dec = return dec     wrapGenArgSyms _          ss dec = wrapGenSyms ss dec -rep_bind (dL->L _ (PatSynBind _ (XPatSynBind _)))-  = panic "rep_bind: XPatSynBind"-rep_bind (dL->L _ (XHsBindsLR {}))  = panic "rep_bind: XHsBindsLR"+rep_bind (dL->L _ (PatSynBind _ (XPatSynBind nec)))+  = noExtCon nec+rep_bind (dL->L _ (XHsBindsLR nec)) = noExtCon nec rep_bind _                          = panic "rep_bind: Impossible match!"                                       -- due to #15884 @@ -1764,7 +1758,7 @@ repPatSynDir (ExplicitBidirectional (MG { mg_alts = (dL->L _ clauses) }))   = do { clauses' <- mapM repClauseTup clauses        ; repExplBidirPatSynDir (nonEmptyCoreList clauses') }-repPatSynDir (ExplicitBidirectional (XMatchGroup _)) = panic "repPatSynDir"+repPatSynDir (ExplicitBidirectional (XMatchGroup nec)) = noExtCon nec  repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ) repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]@@ -1804,7 +1798,7 @@                 do { xs <- repLPs ps; body <- repLE e; repLam xs body })       ; wrapGenSyms ss lam } -repLambda (dL->L _ m) = notHandled "Guarded labmdas" (pprMatch m)+repLambda (dL->L _ m) = notHandled "Guarded lambdas" (pprMatch m)   -----------------------------------------------------------------------------@@ -1951,7 +1945,7 @@         ; rep2 mk_varg [pkg,mod,occ] }   | otherwise   = do  { MkC occ <- nameLit name-        ; MkC uni <- coreIntLit (getKey (getUnique name))+        ; MkC uni <- coreIntegerLit (toInteger $ getKey (getUnique name))         ; rep2 mkNameLName [occ,uni] }   where       mod = ASSERT( isExternalName name) nameModule name@@ -2108,10 +2102,10 @@ repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ) repLamCase (MkC ms) = rep2 lamCaseEName [ms] -repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)+repTup :: Core [Maybe TH.ExpQ] -> DsM (Core TH.ExpQ) repTup (MkC es) = rep2 tupEName [es] -repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)+repUnboxedTup :: Core [Maybe TH.ExpQ] -> DsM (Core TH.ExpQ) repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]  repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ)@@ -2131,7 +2125,7 @@ repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ) repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e] -repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)+repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM (Core TH.ExpQ) repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]  repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)@@ -2467,6 +2461,10 @@ repTForall (MkC tvars) (MkC ctxt) (MkC ty)     = rep2 forallTName [tvars, ctxt, ty] +repTForallVis :: Core [TH.TyVarBndrQ] -> Core TH.TypeQ+              -> DsM (Core TH.TypeQ)+repTForallVis (MkC tvars) (MkC ty) = rep2 forallVisTName [tvars, ty]+ repTvar :: Core TH.Name -> DsM (Core TH.TypeQ) repTvar (MkC s) = rep2 varTName [s] @@ -2616,7 +2614,7 @@  mk_rational :: FractionalLit -> DsM (HsLit GhcRn) mk_rational r = do rat_ty <- lookupType rationalTyConName-                   return $ HsRat noExt r rat_ty+                   return $ HsRat noExtField r rat_ty mk_string :: FastString -> DsM (HsLit GhcRn) mk_string s = return $ HsString NoSourceText s @@ -2629,7 +2627,7 @@         -- The type Rational will be in the environment, because         -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,         -- and rationalL is sucked in when any TH stuff is used-repOverloadedLiteral XOverLit{} = panic "repOverloadedLiteral"+repOverloadedLiteral (XOverLit nec) = noExtCon nec  mk_lit :: OverLitVal -> DsM (HsLit GhcRn) mk_lit (HsIntegral i)     = mk_integer  (il_value i)@@ -2743,6 +2741,9 @@ coreIntLit :: Int -> DsM (Core Int) coreIntLit i = do dflags <- getDynFlags                   return (MkC (mkIntExprInt dflags i))++coreIntegerLit :: Integer -> DsM (Core Integer)+coreIntegerLit i = fmap MkC (mkIntegerExpr i)  coreVar :: Id -> Core TH.Name   -- The Id has type Name coreVar id = MkC (Var id)
compiler/deSugar/DsMonad.hs view
@@ -29,11 +29,11 @@          DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv, -        -- Getting and setting EvVars and term constraints in local environment-        getDictsDs, addDictsDs, getTmCsDs, addTmCsDs,+        -- Getting and setting pattern match oracle states+        getPmDelta, updPmDelta, -        -- Iterations for pm checking-        incrCheckPmIterDs, resetPmIterDs, dsGetCompleteMatches,+        -- Get COMPLETE sets of a TyCon+        dsGetCompleteMatches,          -- Warnings and errors         DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr,@@ -59,7 +59,7 @@ import CoreSyn import MkCore    ( unitExpr ) import CoreUtils ( exprType, isExprLevPoly )-import HsSyn+import GHC.Hs import TcIface import TcMType ( checkForLevPolyX, formatLevPolyErr ) import PrelNames@@ -70,7 +70,7 @@ import DataCon import ConLike import TyCon-import PmExpr+import GHC.HsToCore.PmCheck.Types import Id import Module import Outputable@@ -82,7 +82,6 @@ import DynFlags import ErrUtils import FastString-import Var (EvVar) import UniqFM ( lookupWithDefaultUFM ) import Literal ( mkLitString ) import CostCentreState@@ -191,8 +190,7 @@                   => HscEnv -> IORef Messages -> TcGblEnv                   -> m (DsGblEnv, DsLclEnv) mkDsEnvsFromTcGbl hsc_env msg_var tcg_env-  = do { pm_iter_var <- liftIO $ newIORef 0-       ; cc_st_var   <- liftIO $ newIORef newCostCentreState+  = do { cc_st_var   <- liftIO $ newIORef newCostCentreState        ; let dflags   = hsc_dflags hsc_env              this_mod = tcg_mod tcg_env              type_env = tcg_type_env tcg_env@@ -201,7 +199,7 @@              complete_matches = hptCompleteSigs hsc_env                                 ++ tcg_complete_matches tcg_env        ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env-                           msg_var pm_iter_var cc_st_var complete_matches+                           msg_var cc_st_var complete_matches        }  runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)@@ -220,8 +218,7 @@ -- | Run a 'DsM' action in the context of an existing 'ModGuts' initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a) initDsWithModGuts hsc_env guts thing_inside-  = do { pm_iter_var <- newIORef 0-       ; cc_st_var   <- newIORef newCostCentreState+  = do { cc_st_var   <- newIORef newCostCentreState        ; msg_var <- newIORef emptyMessages        ; let dflags   = hsc_dflags hsc_env              type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)@@ -236,8 +233,8 @@              ids = concatMap bindsToIds (mg_binds guts)               envs  = mkDsEnvs dflags this_mod rdr_env type_env-                              fam_inst_env msg_var pm_iter_var-                              cc_st_var complete_matches+                              fam_inst_env msg_var cc_st_var+                              complete_matches        ; runDs hsc_env envs thing_inside        } @@ -265,9 +262,9 @@          thing_inside }  mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv-         -> IORef Messages -> IORef Int -> IORef CostCentreState-         -> [CompleteMatch] -> (DsGblEnv, DsLclEnv)-mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar cc_st_var+         -> IORef Messages -> IORef CostCentreState -> [CompleteMatch]+         -> (DsGblEnv, DsLclEnv)+mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var          complete_matches   = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs",                              if_rec_types = Just (mod, return type_env) }@@ -285,9 +282,7 @@                            }         lcl_env = DsLclEnv { dsl_meta    = emptyNameEnv                            , dsl_loc     = real_span-                           , dsl_dicts   = emptyBag-                           , dsl_tm_cs   = emptyBag-                           , dsl_pm_iter = pmvar+                           , dsl_delta   = initDelta                            }     in (gbl_env, lcl_env) @@ -386,39 +381,14 @@ getGhcModeDs :: DsM GhcMode getGhcModeDs =  getDynFlags >>= return . ghcMode --- | Get in-scope type constraints (pm check)-getDictsDs :: DsM (Bag EvVar)-getDictsDs = do { env <- getLclEnv; return (dsl_dicts env) }---- | Add in-scope type constraints (pm check)-addDictsDs :: Bag EvVar -> DsM a -> DsM a-addDictsDs ev_vars-  = updLclEnv (\env -> env { dsl_dicts = unionBags ev_vars (dsl_dicts env) })---- | Get in-scope term constraints (pm check)-getTmCsDs :: DsM (Bag SimpleEq)-getTmCsDs = do { env <- getLclEnv; return (dsl_tm_cs env) }---- | Add in-scope term constraints (pm check)-addTmCsDs :: Bag SimpleEq -> DsM a -> DsM a-addTmCsDs tm_cs-  = updLclEnv (\env -> env { dsl_tm_cs = unionBags tm_cs (dsl_tm_cs env) })---- | Increase the counter for elapsed pattern match check iterations.--- If the current counter is already over the limit, fail-incrCheckPmIterDs :: DsM Int-incrCheckPmIterDs = do-  env <- getLclEnv-  cnt <- readTcRef (dsl_pm_iter env)-  max_iters <- maxPmCheckIterations <$> getDynFlags-  if cnt >= max_iters-    then failM-    else updTcRef (dsl_pm_iter env) (+1)-  return cnt+-- | Get the current pattern match oracle state. See 'dsl_delta'.+getPmDelta :: DsM Delta+getPmDelta = do { env <- getLclEnv; return (dsl_delta env) } --- | Reset the counter for pattern match check iterations to zero-resetPmIterDs :: DsM ()-resetPmIterDs = do { env <- getLclEnv; writeTcRef (dsl_pm_iter env) 0 }+-- | Set the pattern match oracle state within the scope of the given action.+-- See 'dsl_delta'.+updPmDelta :: Delta -> DsM a -> DsM a+updPmDelta delta = updLclEnv (\env -> env { dsl_delta = delta })  getSrcSpanDs :: DsM SrcSpan getSrcSpanDs = do { env <- getLclEnv@@ -486,7 +456,7 @@       ; env <- getGblEnv       ; mb_res <- tryM $  -- Be careful to catch exceptions                           -- so that we propagate errors correctly-                          -- (Trac #13642)+                          -- (#13642)                   setGblEnv (env { ds_msgs = errs_var }) $                   thing_inside
compiler/deSugar/DsUsage.hs view
@@ -7,7 +7,7 @@     mkUsageInfo, mkUsedNames, mkDependencies     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -50,7 +50,7 @@ Consequently, A will contain itself in its imp_orphs due to its import of B. This fact would end up being recorded in A's interface file. This would then break the invariant asserted by calculateAvails that a module does not itself in-its dep_orphs. This was the cause of Trac #14128.+its dep_orphs. This was the cause of #14128.  -} @@ -314,15 +314,15 @@                       usg_entities = Map.toList ent_hashs,                       usg_safe     = imp_safe }       where-        maybe_iface  = lookupIfaceByModule dflags hpt pit mod+        maybe_iface  = lookupIfaceByModule hpt pit mod                 -- In one-shot mode, the interfaces for home-package                 -- modules accumulate in the PIT not HPT.  Sigh.          Just iface   = maybe_iface-        finsts_mod   = mi_finsts    iface-        hash_env     = mi_hash_fn   iface-        mod_hash     = mi_mod_hash  iface-        export_hash | depend_on_exports = Just (mi_exp_hash iface)+        finsts_mod   = mi_finsts (mi_final_exts iface)+        hash_env     = mi_hash_fn (mi_final_exts iface)+        mod_hash     = mi_mod_hash (mi_final_exts iface)+        export_hash | depend_on_exports = Just (mi_exp_hash (mi_final_exts iface))                     | otherwise         = Nothing          by_is_safe (ImportedByUser imv) = imv_is_safe imv
compiler/deSugar/DsUtils.hs view
@@ -32,7 +32,7 @@         seqVar,          -- LHs tuples-        mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat,+        mkLHsPatTup, mkVanillaTuplePat,         mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId,          mkSelectorBinds,@@ -42,14 +42,14 @@         isTrueLHsExpr     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import {-# SOURCE #-} Match  ( matchSimply ) import {-# SOURCE #-} DsExpr ( dsLExpr ) -import HsSyn+import GHC.Hs import TcHsSyn import TcType( tcSplitTyConApp ) import CoreSyn@@ -243,8 +243,7 @@   | otherwise   = Let (NonRec new (varToCoreExpr old)) body  seqVar :: Var -> CoreExpr -> CoreExpr-seqVar var body = Case (Var var) var (exprType body)-                        [(DEFAULT, [], body)]+seqVar var body = mkDefaultCase (Var var) var body  mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)@@ -409,82 +408,88 @@     return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg])  {--'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.+'mkCoreAppDs' and 'mkCoreAppsDs' handle the special-case desugaring of 'seq'. -Note [Desugaring seq (1)]  cf Trac #1031-~~~~~~~~~~~~~~~~~~~~~~~~~-   f x y = x `seq` (y `seq` (# x,y #))+Note [Desugaring seq]+~~~~~~~~~~~~~~~~~~~~~ -The [CoreSyn let/app invariant] means that, other things being equal, because-the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:+There are a few subtleties in the desugaring of `seq`: -   f x y = case (y `seq` (# x,y #)) of v -> x `seq` v+ 1. (as described in #1031) -But that is bad for two reasons:-  (a) we now evaluate y before x, and-  (b) we can't bind v to an unboxed pair+    Consider,+       f x y = x `seq` (y `seq` (# x,y #)) -Seq is very, very special!  So we recognise it right here, and desugar to-        case x of _ -> case y of _ -> (# x,y #)+    The [CoreSyn let/app invariant] means that, other things being equal, because+    the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus: -Note [Desugaring seq (2)]  cf Trac #2273-~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   let chp = case b of { True -> fst x; False -> 0 }-   in chp `seq` ...chp...-Here the seq is designed to plug the space leak of retaining (snd x)-for too long.+       f x y = case (y `seq` (# x,y #)) of v -> x `seq` v -If we rely on the ordinary inlining of seq, we'll get-   let chp = case b of { True -> fst x; False -> 0 }-   case chp of _ { I# -> ...chp... }+    But that is bad for two reasons:+      (a) we now evaluate y before x, and+      (b) we can't bind v to an unboxed pair -But since chp is cheap, and the case is an alluring contet, we'll-inline chp into the case scrutinee.  Now there is only one use of chp,-so we'll inline a second copy.  Alas, we've now ruined the purpose of-the seq, by re-introducing the space leak:-    case (case b of {True -> fst x; False -> 0}) of-      I# _ -> ...case b of {True -> fst x; False -> 0}...+    Seq is very, very special!  So we recognise it right here, and desugar to+            case x of _ -> case y of _ -> (# x,y #) -We can try to avoid doing this by ensuring that the binder-swap in the-case happens, so we get his at an early stage:-   case chp of chp2 { I# -> ...chp2... }-But this is fragile.  The real culprit is the source program.  Perhaps we-should have said explicitly-   let !chp2 = chp in ...chp2...+ 2. (as described in #2273) -But that's painful.  So the code here does a little hack to make seq-more robust: a saturated application of 'seq' is turned *directly* into-the case expression, thus:-   x  `seq` e2 ==> case x of x -> e2    -- Note shadowing!-   e1 `seq` e2 ==> case x of _ -> e2+    Consider+       let chp = case b of { True -> fst x; False -> 0 }+       in chp `seq` ...chp...+    Here the seq is designed to plug the space leak of retaining (snd x)+    for too long. -So we desugar our example to:-   let chp = case b of { True -> fst x; False -> 0 }-   case chp of chp { I# -> ...chp... }-And now all is well.+    If we rely on the ordinary inlining of seq, we'll get+       let chp = case b of { True -> fst x; False -> 0 }+       case chp of _ { I# -> ...chp... } -The reason it's a hack is because if you define mySeq=seq, the hack-won't work on mySeq.+    But since chp is cheap, and the case is an alluring contet, we'll+    inline chp into the case scrutinee.  Now there is only one use of chp,+    so we'll inline a second copy.  Alas, we've now ruined the purpose of+    the seq, by re-introducing the space leak:+        case (case b of {True -> fst x; False -> 0}) of+          I# _ -> ...case b of {True -> fst x; False -> 0}... -Note [Desugaring seq (3)] cf Trac #2409-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The isLocalId ensures that we don't turn-        True `seq` e-into-        case True of True { ... }-which stupidly tries to bind the datacon 'True'.+    We can try to avoid doing this by ensuring that the binder-swap in the+    case happens, so we get his at an early stage:+       case chp of chp2 { I# -> ...chp2... }+    But this is fragile.  The real culprit is the source program.  Perhaps we+    should have said explicitly+       let !chp2 = chp in ...chp2...++    But that's painful.  So the code here does a little hack to make seq+    more robust: a saturated application of 'seq' is turned *directly* into+    the case expression, thus:+       x  `seq` e2 ==> case x of x -> e2    -- Note shadowing!+       e1 `seq` e2 ==> case x of _ -> e2++    So we desugar our example to:+       let chp = case b of { True -> fst x; False -> 0 }+       case chp of chp { I# -> ...chp... }+    And now all is well.++    The reason it's a hack is because if you define mySeq=seq, the hack+    won't work on mySeq.++ 3. (as described in #2409)++    The isLocalId ensures that we don't turn+            True `seq` e+    into+            case True of True { ... }+    which stupidly tries to bind the datacon 'True'. -}  -- NB: Make sure the argument is not levity polymorphic mkCoreAppDs  :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr-mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2-  | f `hasKey` seqIdKey            -- Note [Desugaring seq (1), (2)]+mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg2+  | f `hasKey` seqIdKey            -- Note [Desugaring seq], points (1) and (2)   = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]   where     case_bndr = case arg1 of                    Var v1 | isInternalName (idName v1)-                          -> v1        -- Note [Desugaring seq (2) and (3)]+                          -> v1        -- Note [Desugaring seq], points (2) and (3)                    _      -> mkWildValBinder ty1  mkCoreAppDs s fun arg = mkCoreApp s fun arg  -- The rest is done in MkCore@@ -747,7 +752,7 @@ *                                                                      *   Creating big tuples and their types for full Haskell expressions.   They work over *Ids*, and create tuples replete with their types,-  which is whey they are not in HsUtils.+  which is whey they are not in GHC.Hs.Utils. *                                                                      * ********************************************************************* -} @@ -757,9 +762,6 @@ mkLHsPatTup lpats  = cL (getLoc (head lpats)) $                      mkVanillaTuplePat lpats Boxed -mkLHsVarPatTup :: [Id] -> LPat GhcTc-mkLHsVarPatTup bs  = mkLHsPatTup (map nlVarPat bs)- mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc -- A vanilla tuple pattern simply gets its type from its sub-patterns mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box@@ -849,7 +851,7 @@                       CoreExpr) -- Fail variable applied to realWorld# -- See Note [Failure thunks and CPR] mkFailurePair expr-  = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkFunTy` ty)+  = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkVisFunTy` ty)        ; fail_fun_arg <- newSysLocalDs voidPrimTy        ; let real_arg = setOneShotLambda fail_fun_arg        ; return (NonRec fail_fun_var (Lam real_arg expr),@@ -879,7 +881,7 @@ entered at most once.  Adding a dummy 'realWorld' token argument makes it clear that sharing is not an issue.  And that in turn makes it more CPR-friendly.  This matters a lot: if you don't get it right, you lose-the tail call property.  For example, see Trac #3403.+the tail call property.  For example, see #3403.   ************************************************************************@@ -955,7 +957,7 @@            ParPat x p    -> cL l (ParPat x (go p))            LazyPat _ lp' -> lp'            BangPat _ _   -> lp-           _             -> cL l (BangPat noExt lp)+           _             -> cL l (BangPat noExtField lp)  -- | Unconditionally make a 'Pat' strict. addBang :: LPat GhcTc -- ^ Original pattern@@ -965,10 +967,10 @@     go lp@(dL->L l p)       = case p of            ParPat x p    -> cL l (ParPat x (go p))-           LazyPat _ lp' -> cL l (BangPat noExt lp')+           LazyPat _ lp' -> cL l (BangPat noExtField lp')                                   -- Should we bring the extension value over?            BangPat _ _   -> lp-           _             -> cL l (BangPat noExt lp)+           _             -> cL l (BangPat noExtField lp)  isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
compiler/deSugar/ExtractDocs.hs view
@@ -8,18 +8,19 @@  import GhcPrelude import Bag-import HsBinds-import HsDoc-import HsDecls-import HsExtension-import HsTypes-import HsUtils+import GHC.Hs.Binds+import GHC.Hs.Doc+import GHC.Hs.Decls+import GHC.Hs.Extension+import GHC.Hs.Types+import GHC.Hs.Utils import Name import NameSet import SrcLoc import TcRnTypes  import Control.Applicative+import Data.Bifunctor (first) import Data.List import Data.Map (Map) import qualified Data.Map as M@@ -136,7 +137,7 @@ -- Extract the source location where an instance is defined. This is used -- to correlate InstDecls with their Instance/CoAxiom Names, via the -- instanceMap.-getInstLoc :: InstDecl name -> SrcSpan+getInstLoc :: InstDecl (GhcPass p) -> SrcSpan getInstLoc = \case   ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty)   DataFamInstD _ (DataFamInstDecl@@ -191,11 +192,22 @@                   , (dL->L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)                   , (dL->L _ n) <- ns ]         derivs  = [ (instName, [unLoc doc], M.empty)-                  | HsIB { hsib_body = (dL->L l (HsDocTy _ _ doc)) }-                      <- concatMap (unLoc . deriv_clause_tys . unLoc) $-                           unLoc $ dd_derivs dd+                  | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $+                                concatMap (unLoc . deriv_clause_tys . unLoc) $+                                unLoc $ dd_derivs dd                   , Just instName <- [M.lookup l instMap] ] +        extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString)+        extract_deriv_ty ty =+          case dL ty of+            -- deriving (forall a. C a {- ^ Doc comment -})+            L l (HsForAllTy{ hst_fvf = ForallInvis+                           , hst_body = dL->L _ (HsDocTy _ _ doc) })+                                  -> Just (l, doc)+            -- deriving (C a {- ^ Doc comment -})+            L l (HsDocTy _ _ doc) -> Just (l, doc)+            _                     -> Nothing+ -- | Extract constructor argument docs from inside constructor decls. conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString) conArgDocs con = case getConArgs con of@@ -203,9 +215,10 @@                    InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret)                    RecCon _ -> go 1 ret   where-    go n (HsDocTy _ _ (dL->L _ ds) : tys) = M.insert n ds $ go (n+1) tys-    go n (_ : tys) = go (n+1) tys-    go _ [] = M.empty+    go n = M.fromList . catMaybes . zipWith f [n..]+      where+        f n (HsDocTy _ _ lds) = Just (n, unLoc lds)+        f _ _ = Nothing      ret = case con of             ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ]@@ -221,10 +234,10 @@ classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls   where     decls = docs ++ defs ++ sigs ++ ats-    docs  = mkDecls tcdDocs (DocD noExt) class_-    defs  = mkDecls (bagToList . tcdMeths) (ValD noExt) class_-    sigs  = mkDecls tcdSigs (SigD noExt) class_-    ats   = mkDecls tcdATs (TyClD noExt . FamDecl noExt) class_+    docs  = mkDecls tcdDocs (DocD noExtField) class_+    defs  = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_+    sigs  = mkDecls tcdSigs (SigD noExtField) class_+    ats   = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_  -- | Extract function argument docs from inside top-level decls. declTypeDocs :: HsDecl GhcRn -> Map Int (HsDocString)@@ -251,14 +264,13 @@ typeDocs :: HsType GhcRn -> Map Int (HsDocString) typeDocs = go 0   where-    go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty)-    go n (HsQualTy   { hst_body = ty }) = go n (unLoc ty)-    go n (HsFunTy _ (dL->L _-                      (HsDocTy _ _ (dL->L _ x))) (dL->L _ ty)) =-       M.insert n x $ go (n+1) ty-    go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty)-    go n (HsDocTy _ _ (dL->L _ doc)) = M.singleton n doc-    go _ _ = M.empty+    go n = \case+      HsForAllTy { hst_body = ty }        -> go n (unLoc ty)+      HsQualTy   { hst_body = ty }        -> go n (unLoc ty)+      HsFunTy _ (unLoc->HsDocTy _ _ x) ty -> M.insert n (unLoc x) $ go (n+1) (unLoc ty)+      HsFunTy _ _ ty                      -> go (n+1) (unLoc ty)+      HsDocTy _ _ doc                     -> M.singleton n (unLoc doc)+      _                                   -> M.empty  -- | The top-level declarations of a module that we care about, -- ordered by source location, with documentation attached if it exists.@@ -268,21 +280,21 @@ -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] ungroup group_ =-  mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExt)  group_ ++-  mkDecls hs_derivds             (DerivD noExt) group_ ++-  mkDecls hs_defds               (DefD noExt)   group_ ++-  mkDecls hs_fords               (ForD noExt)   group_ ++-  mkDecls hs_docs                (DocD noExt)   group_ ++-  mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExt)  group_ ++-  mkDecls (typesigs . hs_valds)  (SigD noExt)   group_ ++-  mkDecls (valbinds . hs_valds)  (ValD noExt)   group_+  mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField)  group_ +++  mkDecls hs_derivds             (DerivD noExtField) group_ +++  mkDecls hs_defds               (DefD noExtField)   group_ +++  mkDecls hs_fords               (ForD noExtField)   group_ +++  mkDecls hs_docs                (DocD noExtField)   group_ +++  mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField)  group_ +++  mkDecls (typesigs . hs_valds)  (SigD noExtField)   group_ +++  mkDecls (valbinds . hs_valds)  (ValD noExtField)   group_   where-    typesigs (XValBindsLR (NValBinds _ sigs)) = filter (isUserSig . unLoc) sigs-    typesigs _ = error "expected ValBindsOut"+    typesigs (XValBindsLR (NValBinds _ sig)) = filter (isUserSig . unLoc) sig+    typesigs ValBinds{} = error "expected XValBindsLR"      valbinds (XValBindsLR (NValBinds binds _)) =       concatMap bagToList . snd . unzip $ binds-    valbinds _ = error "expected ValBindsOut"+    valbinds ValBinds{} = error "expected XValBindsLR"  -- | Sort by source location sortByLoc :: [Located a] -> [Located a]@@ -293,17 +305,16 @@ -- A declaration may have multiple doc strings attached to it. collectDocs :: [LHsDecl pass] -> [(LHsDecl pass, [HsDocString])] -- ^ This is an example.-collectDocs = go Nothing []+collectDocs = go [] Nothing   where-    go Nothing _ [] = []-    go (Just prev) docs [] = finished prev docs []-    go prev docs ((dL->L _ (DocD _ (DocCommentNext str))) : ds)-      | Nothing <- prev = go Nothing (str:docs) ds-      | Just decl <- prev = finished decl docs (go Nothing [str] ds)-    go prev docs ((dL->L _ (DocD _ (DocCommentPrev str))) : ds) =-      go prev (str:docs) ds-    go Nothing docs (d:ds) = go (Just d) docs ds-    go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)+    go docs mprev decls = case (decls, mprev) of+      ((unLoc->DocD _ (DocCommentNext s)) : ds, Nothing)   -> go (s:docs) Nothing ds+      ((unLoc->DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [s] Nothing ds+      ((unLoc->DocD _ (DocCommentPrev s)) : ds, mprev)     -> go (s:docs) mprev ds+      (d                                  : ds, Nothing)   -> go docs (Just d) ds+      (d                                  : ds, Just prev) -> finished prev docs $ go [] (Just d) ds+      ([]                                     , Nothing)   -> []+      ([]                                     , Just prev) -> finished prev docs []      finished decl docs rest = (decl, reverse docs) : rest @@ -324,13 +335,12 @@  -- | Go through all class declarations and filter their sub-declarations filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]-filterClasses decls = [ if isClassD d then (cL loc (filterClass d), doc) else x-                      | x@(dL->L loc d, doc) <- decls ]+filterClasses = map (first (mapLoc filterClass))   where-    filterClass (TyClD x c) =+    filterClass (TyClD x c@(ClassDecl {})) =       TyClD x $ c { tcdSigs =         filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) }-    filterClass _ = error "expected TyClD"+    filterClass d = d  -- | Was this signature given by the user? isUserSig :: Sig name -> Bool@@ -339,12 +349,10 @@ isUserSig PatSynSig {}  = True isUserSig _             = False -isClassD :: HsDecl a -> Bool-isClassD (TyClD _ d) = isClassDecl d-isClassD _ = False- -- | Take a field of declarations from a data structure and create HsDecls -- using the given constructor-mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]-mkDecls field con struct = [ cL loc (con decl)-                           | (dL->L loc decl) <- field struct ]+mkDecls :: (struct -> [Located decl])+        -> (decl -> hsDecl)+        -> struct+        -> [Located hsDecl]+mkDecls field con = map (mapLoc con) . field
compiler/deSugar/Match.hs view
@@ -13,7 +13,7 @@ module Match ( match, matchEquations, matchWrapper, matchSimply              , matchSinglePat, matchSinglePatVar ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -21,11 +21,11 @@  import BasicTypes ( Origin(..) ) import DynFlags-import HsSyn+import GHC.Hs import TcHsSyn import TcEvidence import TcRnMonad-import Check+import GHC.HsToCore.PmCheck import CoreSyn import Literal import CoreUtils@@ -154,7 +154,7 @@ is the scrutinee(s) of the match. The desugared expression may sometimes use that Id in a local binding or as a case binder.  So it should not have an External name; Lint rejects non-top-level binders-with External names (Trac #13043).+with External names (#13043).  See also Note [Localise pattern binders] in DsUtils -}@@ -501,9 +501,9 @@ -- Push the bang-pattern inwards, in the hope that -- it may disappear next time tidy_bang_pat v o l (AsPat x v' p)-  = tidy1 v o (AsPat x v' (cL l (BangPat noExt p)))+  = tidy1 v o (AsPat x v' (cL l (BangPat noExtField p))) tidy_bang_pat v o l (CoPat x w p t)-  = tidy1 v o (CoPat x w (BangPat noExt (cL l p)) t)+  = tidy1 v o (CoPat x w (BangPat noExtField (cL l p)) t)  -- Discard bang around strict pattern tidy_bang_pat v o _ p@(LitPat {})    = tidy1 v o p@@ -515,7 +515,7 @@ tidy_bang_pat v o l p@(ConPatOut { pat_con = (dL->L _ (RealDataCon dc))                                  , pat_args = args                                  , pat_arg_tys = arg_tys })-  -- Newtypes: push bang inwards (Trac #9844)+  -- Newtypes: push bang inwards (#9844)   =     if isNewTyCon (dataConTyCon dc)       then tidy1 v o (p { pat_args = push_bang_into_newtype_arg l ty args })@@ -534,11 +534,11 @@ --    NPlusKPat -- -- For LazyPat, remember that it's semantically like a VarPat---  i.e.  !(~p) is not like ~p, or p!  (Trac #8952)+--  i.e.  !(~p) is not like ~p, or p!  (#8952) -- -- NB: SigPatIn, ConPatIn should not happen -tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExt (cL l p))+tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (cL l p))  ------------------- push_bang_into_newtype_arg :: SrcSpan@@ -549,16 +549,16 @@ -- We are transforming   !(N p)   into   (N !p) push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))   = ASSERT( null args)-    PrefixCon [cL l (BangPat noExt arg)]+    PrefixCon [cL l (BangPat noExtField arg)] push_bang_into_newtype_arg l _ty (RecCon rf)   | HsRecFields { rec_flds = (dL->L lf fld) : flds } <- rf   , HsRecField { hsRecFieldArg = arg } <- fld   = ASSERT( null flds)     RecCon (rf { rec_flds = [cL lf (fld { hsRecFieldArg-                                           = cL l (BangPat noExt arg) })] })+                                           = cL l (BangPat noExtField arg) })] }) push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})   | HsRecFields { rec_flds = [] } <- rf-  = PrefixCon [cL l (BangPat noExt (noLoc (WildPat ty)))]+  = PrefixCon [cL l (BangPat noExtField (noLoc (WildPat ty)))] push_bang_into_newtype_arg _ _ cd   = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) @@ -568,7 +568,7 @@ For the pattern  !(Just pat)  we can discard the bang, because the pattern is strict anyway. But for !(N pat), where   newtype NT = N Int-we definitely can't discard the bang.  Trac #9844.+we definitely can't discard the bang.  #9844.  So what we do is to push the bang inwards, in the hope that it will get discarded there.  So we transform@@ -690,7 +690,13 @@  matchWrapper   :: HsMatchContext Name               -- ^ For shadowing warning messages-  -> Maybe (LHsExpr GhcTc)             -- ^ Scrutinee, if we check a case expr+  -> Maybe (LHsExpr GhcTc)             -- ^ Scrutinee. (Just scrut) for a case expr+                                       --      case scrut of { p1 -> e1 ... }+                                       --   (and in this case the MatchGroup will+                                       --    have all singleton patterns)+                                       --   Nothing for a function definition+                                       --      f p1 q1 = ...  -- No "scrutinee"+                                       --      f p2 q2 = ...  -- in this case   -> MatchGroup GhcTc (LHsExpr GhcTc)  -- ^ Matches being desugared   -> DsM ([Id], CoreExpr)              -- ^ Results (usually passed to 'match') @@ -730,35 +736,40 @@          ; eqns_info   <- mapM (mk_eqn_info new_vars) matches -        -- pattern match check warnings-        ; unless (isGenerated origin) $-          when (isAnyPmCheckEnabled dflags (DsMatchContext ctxt locn)) $-          addTmCsDs (genCaseTmCs1 mb_scr new_vars) $-              -- See Note [Type and Term Equality Propagation]-          checkMatches dflags (DsMatchContext ctxt locn) new_vars matches+        -- Pattern match check warnings for /this match-group/+        ; when (isMatchContextPmChecked dflags origin ctxt) $+            addScrutTmCs mb_scr new_vars $+            -- See Note [Type and Term Equality Propagation]+            checkMatches dflags (DsMatchContext ctxt locn) new_vars matches          ; result_expr <- handleWarnings $                          matchEquations ctxt new_vars eqns_info rhs_ty         ; return (new_vars, result_expr) }   where+    -- Called once per equation in the match, or alternative in the case     mk_eqn_info vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss }))       = do { dflags <- getDynFlags            ; let upats = map (unLoc . decideBangHood dflags) pats                  dicts = collectEvVarsPats upats-           ; tm_cs <- genCaseTmCs2 mb_scr upats vars-           ; match_result <- addDictsDs dicts $ -- See Note [Type and Term Equality Propagation]-                             addTmCsDs tm_cs  $ -- See Note [Type and Term Equality Propagation]-                             dsGRHSs ctxt grhss rhs_ty++           ; match_result <-+              -- Extend the environment with knowledge about+              -- the matches before desguaring the RHS+              -- See Note [Type and Term Equality Propagation]+              applyWhen (needToRunPmCheck dflags origin)+                        (addTyCsDs dicts . addScrutTmCs mb_scr vars . addPatTmCs upats vars)+                        (dsGRHSs ctxt grhss rhs_ty)+            ; return (EqnInfo { eqn_pats = upats                              , eqn_orig = FromSource                              , eqn_rhs = match_result }) }-    mk_eqn_info _ (dL->L _ (XMatch _)) = panic "matchWrapper"+    mk_eqn_info _ (dL->L _ (XMatch nec)) = noExtCon nec     mk_eqn_info _ _  = panic "mk_eqn_info: Impossible Match" -- due to #15884      handleWarnings = if isGenerated origin                      then discardWarningsDs                      else id-matchWrapper _ _ (XMatchGroup _) = panic "matchWrapper"+matchWrapper _ _ (XMatchGroup nec) = noExtCon nec  matchEquations  :: HsMatchContext Name                 -> [MatchId] -> [EquationInfo] -> Type@@ -926,7 +937,7 @@     ... where P is a pattern synonym, can we put (P a -> e1) and (P b -> e2) in the same group?  We can if P is a constructor, but /not/ if P is a pattern synonym.-Consider (Trac #11224)+Consider (#11224)    -- readMaybe :: Read a => String -> Maybe a    pattern PRead :: Read a => () => a -> String    pattern PRead a <- (readMaybe -> Just a)
compiler/deSugar/Match.hs-boot view
@@ -5,9 +5,9 @@ import TcType   ( Type ) import DsMonad  ( DsM, EquationInfo, MatchResult ) import CoreSyn  ( CoreExpr )-import HsSyn    ( LPat, HsMatchContext, MatchGroup, LHsExpr )+import GHC.Hs   ( LPat, HsMatchContext, MatchGroup, LHsExpr ) import Name     ( Name )-import HsExtension ( GhcTc )+import GHC.Hs.Extension ( GhcTc )  match   :: [Id]         -> Type
compiler/deSugar/MatchCon.hs view
@@ -12,13 +12,13 @@  module MatchCon ( matchConFamily, matchPatSyn ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import {-# SOURCE #-} Match     ( match ) -import HsSyn+import GHC.Hs import DsBinds import ConLike import BasicTypes ( Origin(..) )@@ -242,7 +242,7 @@          f (T { y=True, x=False }) = ...  We must match the patterns IN THE ORDER GIVEN, thus for the first-one we match y=True before x=False.  See Trac #246; or imagine+one we match y=True before x=False.  See #246; or imagine matching against (T { y=False, x=undefined }): should fail without touching the undefined.
compiler/deSugar/MatchLit.hs view
@@ -17,7 +17,7 @@                 , warnAboutEmptyEnumerations                 ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -27,7 +27,7 @@ import DsMonad import DsUtils -import HsSyn+import GHC.Hs  import Id import CoreSyn@@ -95,7 +95,7 @@     HsString _ str   -> mkStringExprFS str     HsInteger _ i _  -> mkIntegerExpr i     HsInt _ i        -> return (mkIntExpr dflags (il_value i))-    XLit x           -> pprPanic "dsLit" (ppr x)+    XLit nec         -> noExtCon nec     HsRat _ (FL _ _ val) ty -> do       num   <- mkIntegerExpr (numerator val)       denom <- mkIntegerExpr (denominator val)@@ -116,7 +116,7 @@   case shortCutLit dflags val ty of     Just expr | not rebindable -> dsExpr expr        -- Note [Literal short cut]     _                          -> dsExpr witness-dsOverLit XOverLit{} = panic "dsOverLit"+dsOverLit (XOverLit nec) = noExtCon nec {- Note [Literal short cut] ~~~~~~~~~~~~~~~~~~~~~~~~@@ -287,7 +287,7 @@  getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name) -- ^ See if the expression is an 'Integral' literal.--- Remember to look through automatically-added tick-boxes! (Trac #8384)+-- Remember to look through automatically-added tick-boxes! (#8384) getLHsIntegralLit (dL->L _ (HsPar _ e))            = getLHsIntegralLit e getLHsIntegralLit (dL->L _ (HsTick _ _ e))         = getLHsIntegralLit e getLHsIntegralLit (dL->L _ (HsBinTick _ _ _ e))    = getLHsIntegralLit e@@ -337,7 +337,7 @@                   (mkNilPat charTy) (unpackFS s)         -- The stringTy is the type of the whole pattern, not         -- the type to instantiate (:) or [] with!-tidyLitPat lit = LitPat noExt lit+tidyLitPat lit = LitPat noExtField lit  ---------------- tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc@@ -349,7 +349,7 @@         -- Once that is settled, look for cases where the type of the         -- entire overloaded literal matches the type of the underlying literal,         -- and in that case take the short cut-        -- NB: Watch out for weird cases like Trac #3382+        -- NB: Watch out for weird cases like #3382         --        f :: Int -> Int         --        f "blah" = 4         --     which might be ok if we have 'instance IsString Int'@@ -363,7 +363,7 @@      -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3      -- If we do convert to the constructor form, we'll generate a case      -- expression on a Float# or Double# and that's not allowed in Core; see-     -- Trac #9238 and Note [Rules for floating-point comparisons] in PrelRules+     -- #9238 and Note [Rules for floating-point comparisons] in PrelRules   where     -- Sometimes (like in test case     -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include@@ -373,7 +373,7 @@      mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc     mk_con_pat con lit-      = unLoc (mkPrefixConPat con [noLoc $ LitPat noExt lit] [])+      = unLoc (mkPrefixConPat con [noLoc $ LitPat noExtField lit] [])      mb_int_lit :: Maybe Integer     mb_int_lit = case (mb_neg, val) of@@ -456,7 +456,7 @@ hsLitKey _      (HsCharPrim   _ c) = mkLitChar            c hsLitKey _      (HsFloatPrim  _ f) = mkLitFloat           (fl_value f) hsLitKey _      (HsDoublePrim _ d) = mkLitDouble          (fl_value d)-hsLitKey _      (HsString _ s)     = LitString (fastStringToByteString s)+hsLitKey _      (HsString _ s)     = LitString (bytesFS s) hsLitKey _      l                  = pprPanic "hsLitKey" (ppr l)  {-
− compiler/deSugar/TmOracle.hs 
@@ -1,263 +0,0 @@-{--Author: George Karachalias <george.karachalias@cs.kuleuven.be>--The term equality oracle. The main export of the module is function `tmOracle'.--}--{-# LANGUAGE CPP, MultiWayIf #-}--module TmOracle (--        -- re-exported from PmExpr-        PmExpr(..), PmLit(..), SimpleEq, ComplexEq, PmVarEnv, falsePmExpr,-        eqPmLit, filterComplex, isNotPmExprOther, runPmPprM, lhsExprToPmExpr,-        hsExprToPmExpr, pprPmExprWithParens,--        -- the term oracle-        tmOracle, TmState, initialTmState, solveOneEq, extendSubst, canDiverge,--        -- misc.-        toComplex, exprDeepLookup, pmLitType, flattenPmVarEnv-    ) where--#include "GhclibHsVersions.h"--import GhcPrelude--import PmExpr--import Id-import Name-import Type-import HsLit-import TcHsSyn-import MonadUtils-import Util--import NameEnv--{--%************************************************************************-%*                                                                      *-                      The term equality oracle-%*                                                                      *-%************************************************************************--}---- | The type of substitutions.-type PmVarEnv = NameEnv PmExpr---- | The environment of the oracle contains---     1. A Bool (are there any constraints we cannot handle? (PmExprOther)).---     2. A substitution we extend with every step and return as a result.-type TmOracleEnv = (Bool, PmVarEnv)---- | Check whether a constraint (x ~ BOT) can succeed,--- given the resulting state of the term oracle.-canDiverge :: Name -> TmState -> Bool-canDiverge x (standby, (_unhandled, env))-  -- If the variable seems not evaluated, there is a possibility for-  -- constraint x ~ BOT to be satisfiable.-  | PmExprVar y <- varDeepLookup env x -- seems not forced-  -- If it is involved (directly or indirectly) in any equality in the-  -- worklist, we can assume that it is already indirectly evaluated,-  -- as a side-effect of equality checking. If not, then we can assume-  -- that the constraint is satisfiable.-  = not $ any (isForcedByEq x) standby || any (isForcedByEq y) standby-  -- Variable x is already in WHNF so the constraint is non-satisfiable-  | otherwise = False--  where-    isForcedByEq :: Name -> ComplexEq -> Bool-    isForcedByEq y (e1, e2) = varIn y e1 || varIn y e2---- | Check whether a variable is in the free variables of an expression-varIn :: Name -> PmExpr -> Bool-varIn x e = case e of-  PmExprVar y    -> x == y-  PmExprCon _ es -> any (x `varIn`) es-  PmExprLit _    -> False-  PmExprEq e1 e2 -> (x `varIn` e1) || (x `varIn` e2)-  PmExprOther _  -> False---- | Flatten the DAG (Could be improved in terms of performance.).-flattenPmVarEnv :: PmVarEnv -> PmVarEnv-flattenPmVarEnv env = mapNameEnv (exprDeepLookup env) env---- | The state of the term oracle (includes complex constraints that cannot--- progress unless we get more information).-type TmState = ([ComplexEq], TmOracleEnv)---- | Initial state of the oracle.-initialTmState :: TmState-initialTmState = ([], (False, emptyNameEnv))---- | Solve a complex equality (top-level).-solveOneEq :: TmState -> ComplexEq -> Maybe TmState-solveOneEq solver_env@(_,(_,env)) complex-  = solveComplexEq solver_env -- do the actual *merging* with existing state-  $ simplifyComplexEq               -- simplify as much as you can-  $ applySubstComplexEq env complex -- replace everything we already know---- | Solve a complex equality.--- Nothing => definitely unsatisfiable--- Just tms => I have added the complex equality and added---             it to the tmstate; the result may or may not be---             satisfiable-solveComplexEq :: TmState -> ComplexEq -> Maybe TmState-solveComplexEq solver_state@(standby, (unhandled, env)) eq@(e1, e2) = case eq of-  -- We cannot do a thing about these cases-  (PmExprOther _,_)            -> Just (standby, (True, env))-  (_,PmExprOther _)            -> Just (standby, (True, env))--  (PmExprLit l1, PmExprLit l2) -> case eqPmLit l1 l2 of-    -- See Note [Undecidable Equality for Overloaded Literals]-    True  -> Just solver_state-    False -> Nothing--  (PmExprCon c1 ts1, PmExprCon c2 ts2)-    | c1 == c2  -> foldlM solveComplexEq solver_state (zip ts1 ts2)-    | otherwise -> Nothing-  (PmExprCon _ [], PmExprEq t1 t2)-    | isTruePmExpr e1  -> solveComplexEq solver_state (t1, t2)-    | isFalsePmExpr e1 -> Just (eq:standby, (unhandled, env))-  (PmExprEq t1 t2, PmExprCon _ [])-    | isTruePmExpr e2   -> solveComplexEq solver_state (t1, t2)-    | isFalsePmExpr e2  -> Just (eq:standby, (unhandled, env))--  (PmExprVar x, PmExprVar y)-    | x == y    -> Just solver_state-    | otherwise -> extendSubstAndSolve x e2 solver_state--  (PmExprVar x, _) -> extendSubstAndSolve x e2 solver_state-  (_, PmExprVar x) -> extendSubstAndSolve x e1 solver_state--  (PmExprEq _ _, PmExprEq _ _) -> Just (eq:standby, (unhandled, env))--  _ -> Just (standby, (True, env)) -- I HATE CATCH-ALLS---- | Extend the substitution and solve the (possibly updated) constraints.-extendSubstAndSolve :: Name -> PmExpr -> TmState -> Maybe TmState-extendSubstAndSolve x e (standby, (unhandled, env))-  = foldlM solveComplexEq new_incr_state (map simplifyComplexEq changed)-  where-    -- Apply the substitution to the worklist and partition them to the ones-    -- that had some progress and the rest. Then, recurse over the ones that-    -- had some progress. Careful about performance:-    -- See Note [Representation of Term Equalities] in deSugar/Check.hs-    (changed, unchanged) = partitionWith (substComplexEq x e) standby-    new_incr_state       = (unchanged, (unhandled, extendNameEnv env x e))---- | When we know that a variable is fresh, we do not actually have to--- check whether anything changes, we know that nothing does. Hence,--- `extendSubst` simply extends the substitution, unlike what--- `extendSubstAndSolve` does.-extendSubst :: Id -> PmExpr -> TmState -> TmState-extendSubst y e (standby, (unhandled, env))-  | isNotPmExprOther simpl_e-  = (standby, (unhandled, extendNameEnv env x simpl_e))-  | otherwise = (standby, (True, env))-  where-    x = idName y-    simpl_e = fst $ simplifyPmExpr $ exprDeepLookup env e---- | Simplify a complex equality.-simplifyComplexEq :: ComplexEq -> ComplexEq-simplifyComplexEq (e1, e2) = (fst $ simplifyPmExpr e1, fst $ simplifyPmExpr e2)---- | Simplify an expression. The boolean indicates if there has been any--- simplification or if the operation was a no-op.-simplifyPmExpr :: PmExpr -> (PmExpr, Bool)--- See Note [Deep equalities]-simplifyPmExpr e = case e of-  PmExprCon c ts -> case mapAndUnzip simplifyPmExpr ts of-                      (ts', bs) -> (PmExprCon c ts', or bs)-  PmExprEq t1 t2 -> simplifyEqExpr t1 t2-  _other_expr    -> (e, False) -- the others are terminals---- | Simplify an equality expression. The equality is given in parts.-simplifyEqExpr :: PmExpr -> PmExpr -> (PmExpr, Bool)--- See Note [Deep equalities]-simplifyEqExpr e1 e2 = case (e1, e2) of-  -- Varables-  (PmExprVar x, PmExprVar y)-    | x == y -> (truePmExpr, True)--  -- Literals-  (PmExprLit l1, PmExprLit l2) -> case eqPmLit l1 l2 of-    -- See Note [Undecidable Equality for Overloaded Literals]-    True  -> (truePmExpr,  True)-    False -> (falsePmExpr, True)--  -- Can potentially be simplified-  (PmExprEq {}, _) -> case (simplifyPmExpr e1, simplifyPmExpr e2) of-    ((e1', True ), (e2', _    )) -> simplifyEqExpr e1' e2'-    ((e1', _    ), (e2', True )) -> simplifyEqExpr e1' e2'-    ((e1', False), (e2', False)) -> (PmExprEq e1' e2', False) -- cannot progress-  (_, PmExprEq {}) -> case (simplifyPmExpr e1, simplifyPmExpr e2) of-    ((e1', True ), (e2', _    )) -> simplifyEqExpr e1' e2'-    ((e1', _    ), (e2', True )) -> simplifyEqExpr e1' e2'-    ((e1', False), (e2', False)) -> (PmExprEq e1' e2', False) -- cannot progress--  -- Constructors-  (PmExprCon c1 ts1, PmExprCon c2 ts2)-    | c1 == c2 ->-        let (ts1', bs1) = mapAndUnzip simplifyPmExpr ts1-            (ts2', bs2) = mapAndUnzip simplifyPmExpr ts2-            (tss, _bss) = zipWithAndUnzip simplifyEqExpr ts1' ts2'-            worst_case  = PmExprEq (PmExprCon c1 ts1') (PmExprCon c2 ts2')-        in  if | not (or bs1 || or bs2) -> (worst_case, False) -- no progress-               | all isTruePmExpr  tss  -> (truePmExpr, True)-               | any isFalsePmExpr tss  -> (falsePmExpr, True)-               | otherwise              -> (worst_case, False)-    | otherwise -> (falsePmExpr, True)--  -- We cannot do anything about the rest..-  _other_equality -> (original, False)--  where-    original = PmExprEq e1 e2 -- reconstruct equality---- | Apply an (un-flattened) substitution to a simple equality.-applySubstComplexEq :: PmVarEnv -> ComplexEq -> ComplexEq-applySubstComplexEq env (e1,e2) = (exprDeepLookup env e1, exprDeepLookup env e2)---- | Apply an (un-flattened) substitution to a variable.-varDeepLookup :: PmVarEnv -> Name -> PmExpr-varDeepLookup env x-  | Just e <- lookupNameEnv env x = exprDeepLookup env e -- go deeper-  | otherwise                  = PmExprVar x          -- terminal-{-# INLINE varDeepLookup #-}---- | Apply an (un-flattened) substitution to an expression.-exprDeepLookup :: PmVarEnv -> PmExpr -> PmExpr-exprDeepLookup env (PmExprVar x)    = varDeepLookup env x-exprDeepLookup env (PmExprCon c es) = PmExprCon c (map (exprDeepLookup env) es)-exprDeepLookup env (PmExprEq e1 e2) = PmExprEq (exprDeepLookup env e1)-                                               (exprDeepLookup env e2)-exprDeepLookup _   other_expr       = other_expr -- PmExprLit, PmExprOther---- | External interface to the term oracle.-tmOracle :: TmState -> [ComplexEq] -> Maybe TmState-tmOracle tm_state eqs = foldlM solveOneEq tm_state eqs---- | Type of a PmLit-pmLitType :: PmLit -> Type -- should be in PmExpr but gives cyclic imports :(-pmLitType (PmSLit   lit) = hsLitType   lit-pmLitType (PmOLit _ lit) = overLitType lit--{- Note [Deep equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~-Solving nested equalities is the most difficult part. The general strategy-is the following:--  * Equalities of the form (True ~ (e1 ~ e2)) are transformed to just-    (e1 ~ e2) and then treated recursively.--  * Equalities of the form (False ~ (e1 ~ e2)) cannot be analyzed unless-    we know more about the inner equality (e1 ~ e2). That's exactly what-    `simplifyEqExpr' tries to do: It takes e1 and e2 and either returns-    truePmExpr, falsePmExpr or (e1' ~ e2') in case it is uncertain. Note-    that it is not e but rather e', since it may perform some-    simplifications deeper.--}
compiler/ghci/ByteCodeAsm.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP, MagicHash, RecordWildCards #-}+{-# LANGUAGE BangPatterns, CPP, DeriveFunctor, MagicHash, RecordWildCards #-} {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} -- --  (c) The University of Glasgow 2002-2006@@ -13,7 +13,7 @@         iNTERP_STACK_CHECK_THRESH   ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -29,11 +29,11 @@ import Literal import TyCon import FastString-import StgCmmLayout     ( ArgRep(..) )+import GHC.StgToCmm.Layout     ( ArgRep(..) ) import SMRep import DynFlags import Outputable-import Platform+import GHC.Platform import Util import Unique import UniqDSet@@ -55,7 +55,7 @@  import Foreign import Data.Char        ( ord )-import Data.List+import Data.List        ( genericLength ) import Data.Map (Map) import Data.Maybe (fromMaybe) import qualified Data.Map as Map@@ -228,9 +228,7 @@   | AllocLabel Word16 (Assembler a)   | Emit Word16 [Operand] (Assembler a)   | NullAsm a--instance Functor Assembler where-    fmap = liftM+  deriving (Functor)  instance Applicative Assembler where     pure = NullAsm
compiler/ghci/ByteCodeGen.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fprof-auto-top #-} --@@ -8,7 +9,7 @@ -- | ByteCodeGen: Generate bytecode from Core module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -22,7 +23,7 @@ import BasicTypes import DynFlags import Outputable-import Platform+import GHC.Platform import Name import MkId import Id@@ -37,18 +38,18 @@ import CoreFVs import Type import RepType-import Kind            ( isLiftedTypeKind ) import DataCon import TyCon import Util import VarSet import TysPrim+import TyCoPpr         ( pprType ) import ErrUtils import Unique import FastString import Panic-import StgCmmClosure    ( NonVoid(..), fromNonVoid, nonVoidIds )-import StgCmmLayout+import GHC.StgToCmm.Closure    ( NonVoid(..), fromNonVoid, nonVoidIds )+import GHC.StgToCmm.Layout import SMRep hiding (WordOff, ByteOff, wordsToBytes) import Bitmap import OrdList@@ -85,7 +86,7 @@             -> Maybe ModBreaks             -> IO CompiledByteCode byteCodeGen hsc_env this_mod binds tycs mb_modBreaks-   = withTiming (pure dflags)+   = withTiming dflags                 (text "ByteCodeGen"<+>brackets (ppr this_mod))                 (const ()) $ do         -- Split top-level binds into strings and others.@@ -157,7 +158,7 @@                -> CoreExpr                -> IO UnlinkedBCO coreExprToBCOs hsc_env this_mod expr- = withTiming (pure dflags)+ = withTiming dflags               (text "ByteCodeGen"<+>brackets (ppr this_mod))               (const ()) $ do       -- create a totally bogus name for the top-level BCO; this@@ -496,16 +497,10 @@ schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V  schemeE d s p e@(AnnVar v)-      -- See Note [Levity-polymorphic join points], step 3.-    | isLPJoinPoint v           = schemeT d s p $-                                  AnnApp (bogus_fvs, AnnVar (protectLPJoinPointId v))-                                         (bogus_fvs, AnnVar voidPrimId)-                         -- schemeT will call splitApp, dropping the fvs.-+      -- See Note [Not-necessarily-lifted join points], step 3.+    | isNNLJoinPoint v          = doTailCall d s p (protectNNLJoinPointId v) [AnnVar voidPrimId]     | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)     | otherwise                 = schemeT d s p e-    where-      bogus_fvs = pprPanic "schemeE bogus_fvs" (ppr v)  schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))    | (AnnVar v, args_r_to_l) <- splitApp rhs,@@ -530,8 +525,8 @@           fvss  = map (fvsToEnv p' . fst) rhss -           -- See Note [Levity-polymorphic join points], step 2.-         (xs',rhss') = zipWithAndUnzip protectLPJoinPointBind xs rhss+           -- See Note [Not-necessarily-lifted join points], step 2.+         (xs',rhss') = zipWithAndUnzip protectNNLJoinPointBind xs rhss           -- Sizes of free vars          size_w = trunc16W . idSizeW dflags@@ -613,7 +608,7 @@           -- type and hence won't be bound in the environment, but the           -- breakpoint will otherwise work fine.           ---          -- NB (Trac #12007) this /also/ applies for if (ty :: TYPE r), where+          -- NB (#12007) this /also/ applies for if (ty :: TYPE r), where           --    r :: RuntimeRep is a variable. This can happen in the           --    continuations for a pattern-synonym matcher           --    match = /\(r::RuntimeRep) /\(a::TYPE r).@@ -622,7 +617,7 @@           -- Here (k n) :: a :: Type r, so we don't know if it's lifted           -- or not; but that should be fine provided we add that void arg. -          id <- newId (mkFunTy realWorldStatePrimTy ty)+          id <- newId (mkVisFunTy realWorldStatePrimTy ty)           st <- newId realWorldStatePrimTy           let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp)))                               (emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id)@@ -680,29 +675,29 @@    = pprPanic "ByteCodeGen.schemeE: unhandled case"                (pprCoreExpr (deAnnotate' expr)) --- Is this Id a levity-polymorphic join point?--- See Note [Levity-polymorphic join points], step 1-isLPJoinPoint :: Id -> Bool-isLPJoinPoint x = isJoinId x &&-                  isNothing (isLiftedType_maybe (idType x))+-- Is this Id a not-necessarily-lifted join point?+-- See Note [Not-necessarily-lifted join points], step 1+isNNLJoinPoint :: Id -> Bool+isNNLJoinPoint x = isJoinId x &&+                   Just True /= isLiftedType_maybe (idType x) --- If necessary, modify this Id and body to protect levity-polymorphic join points.--- See Note [Levity-polymorphic join points], step 2.-protectLPJoinPointBind :: Id -> AnnExpr Id DVarSet -> (Id, AnnExpr Id DVarSet)-protectLPJoinPointBind x rhs@(fvs, _)-  | isLPJoinPoint x-  = (protectLPJoinPointId x, (fvs, AnnLam voidArgId rhs))+-- If necessary, modify this Id and body to protect not-necessarily-lifted join points.+-- See Note [Not-necessarily-lifted join points], step 2.+protectNNLJoinPointBind :: Id -> AnnExpr Id DVarSet -> (Id, AnnExpr Id DVarSet)+protectNNLJoinPointBind x rhs@(fvs, _)+  | isNNLJoinPoint x+  = (protectNNLJoinPointId x, (fvs, AnnLam voidArgId rhs))    | otherwise   = (x, rhs)  -- Update an Id's type to take a Void# argument.--- Precondition: the Id is a levity-polymorphic join point.--- See Note [Levity-polymorphic join points]-protectLPJoinPointId :: Id -> Id-protectLPJoinPointId x-  = ASSERT( isLPJoinPoint x )-    updateVarType (voidPrimTy `mkFunTy`) x+-- Precondition: the Id is a not-necessarily-lifted join point.+-- See Note [Not-necessarily-lifted join points]+protectNNLJoinPointId :: Id -> Id+protectNNLJoinPointId x+  = ASSERT( isNNLJoinPoint x )+    updateVarType (voidPrimTy `mkVisFunTy`) x  {-    Ticked Expressions@@ -712,8 +707,8 @@   the code. When we find such a thing, we pull out the useful information,   and then compile the code as if it was just the expression E. -Note [Levity-polymorphic join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Not-necessarily-lifted join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A join point variable is essentially a goto-label: it is, for example, never used as an argument to another function, and it is called only in tail position. See Note [Join points] and Note [Invariants on join points],@@ -727,23 +722,46 @@ or not; they are all treated uniformly. (Perhaps there is a missed optimization opportunity here, but that is beyond the scope of my (Richard E's) Thursday.) -We thus must have *some* strategy for dealing with levity-polymorphic join-points (LPJPs), because we cannot have a levity-polymorphic variable.-(Not having such a strategy led to #16509, which panicked in the isUnliftedType-check in the AnnVar case of schemeE.) Here is the strategy:+We thus must have *some* strategy for dealing with levity-polymorphic and+unlifted join points. Levity-polymorphic variables are generally not allowed+(though levity-polymorphic join points *are*; see Note [Invariants on join points]+in CoreSyn, point 6), and we don't wish to evaluate unlifted join points eagerly.+The questionable join points are *not-necessarily-lifted join points*+(NNLJPs). (Not having such a strategy led to #16509, which panicked in the+isUnliftedType check in the AnnVar case of schemeE.) Here is the strategy: -1. Detect LPJPs. This is done in isLPJoinPoint.+1. Detect NNLJPs. This is done in isNNLJoinPoint. -2. When binding an LPJP, add a `\ (_ :: Void#) ->` to its RHS, and modify the+2. When binding an NNLJP, add a `\ (_ :: Void#) ->` to its RHS, and modify the    type to tack on a `Void# ->`. (Void# is written voidPrimTy within GHC.)    Note that functions are never levity-polymorphic, so this transformation-   changes an LPJP to a non-levity-polymorphic join point. This is done-   in protectLPJoinPointBind, called from the AnnLet case of schemeE.+   changes an NNLJP to a non-levity-polymorphic join point. This is done+   in protectNNLJoinPointBind, called from the AnnLet case of schemeE. -3. At an occurrence of an LPJP, add an application to void# (called voidPrimId),-   being careful to note the new type of the LPJP. This is done in the AnnVar-   case of schemeE, with help from protectLPJoinPointId.+3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId),+   being careful to note the new type of the NNLJP. This is done in the AnnVar+   case of schemeE, with help from protectNNLJoinPointId. +Here is an example. Suppose we have++  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).+      join j :: a+           j = error @r @a "bloop"+      in case x of+           A -> j+           B -> j+           C -> error @r @a "blurp"++Our plan is to behave is if the code was++  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).+      let j :: (Void# -> a)+          j = \ _ -> error @r @a "bloop"+      in case x of+           A -> j void#+           B -> j void#+           C -> error @r @a "blurp"+ It's a bit hacky, but it works well in practice and is local. I suspect the Right Fix is to take advantage of join points as goto-labels. @@ -1020,7 +1038,7 @@                 return (my_discr alt, rhs_code)            -- If an alt attempts to match on an unboxed tuple or sum, we must            -- bail out, as the bytecode compiler can't handle them.-           -- (See Trac #14608.)+           -- (See #14608.)            | any (\bndr -> typePrimRep (idType bndr) `lengthExceeds` 1) bndrs            = multiValException            -- algebraic alt with some binders@@ -1201,7 +1219,7 @@          push_args    = concatOL pushs_arg          !d_after_args = d0 + wordsToBytes dflags a_reps_sizeW          a_reps_pushed_RAW-            | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep+            | null a_reps_pushed_r_to_l || not (isVoidRep (head a_reps_pushed_r_to_l))             = panic "ByteCodeGen.generateCCall: missing or invalid World token?"             | otherwise             = reverse (tail a_reps_pushed_r_to_l)@@ -1456,7 +1474,7 @@ tested.  This is very weird, but it's the way it is right now.  See Interpreter.c.  We don't acutally need an info-table here; we just need to have the argument to be one-from-top on the stack, hence pushing-a 1-word null. See Trac #8383.+a 1-word null. See #8383. -}  @@ -1883,10 +1901,11 @@ atomPrimRep (AnnVar v)              = bcIdPrimRep v atomPrimRep (AnnLit l)              = typePrimRep1 (literalType l) --- Trac #12128:+-- #12128: -- A case expression can be an atom because empty cases evaluate to bottom. -- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs-atomPrimRep (AnnCase _ _ ty _)      = ASSERT(typePrimRep ty == [LiftedRep]) LiftedRep+atomPrimRep (AnnCase _ _ ty _)      =+  ASSERT(case typePrimRep ty of [LiftedRep] -> True; _ -> False) LiftedRep atomPrimRep (AnnCoercion {})        = VoidRep atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other)) @@ -1919,7 +1938,7 @@           -- See Note [generating code for top-level string literal bindings].         } -newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))+newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor)  ioToBc :: IO a -> BcM a ioToBc io = BcM $ \st -> do@@ -1948,9 +1967,6 @@  returnBc :: a -> BcM a returnBc result = BcM $ \st -> (return (st, result))--instance Functor BcM where-    fmap = liftM  instance Applicative BcM where     pure = returnBc
compiler/ghci/ByteCodeInstr.hs view
@@ -9,15 +9,14 @@         BCInstr(..), ProtoBCO(..), bciStackUse,   ) where -#include "GhclibHsVersions.h"-#include "../includes/MachDeps.h"+#include "HsVersions.h"  import GhcPrelude  import ByteCodeTypes import GHCi.RemoteTypes import GHCi.FFI (C_ffi_cif)-import StgCmmLayout     ( ArgRep(..) )+import GHC.StgToCmm.Layout     ( ArgRep(..) ) import PprCore import Outputable import FastString
compiler/ghci/ByteCodeItbls.hs view
@@ -7,7 +7,7 @@ -- | ByteCodeItbls: Generate infotables for interpreter-made bytecodes module ByteCodeItbls ( mkITbls ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -20,8 +20,8 @@ import DataCon          ( DataCon, dataConRepArgTys, dataConIdentity ) import TyCon            ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) import RepType-import StgCmmLayout     ( mkVirtConstrSizes )-import StgCmmClosure    ( tagForCon, NonVoid (..) )+import GHC.StgToCmm.Layout  ( mkVirtConstrSizes )+import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) ) import Util import Panic
compiler/ghci/ByteCodeLink.hs view
@@ -16,7 +16,7 @@         nameToCLabel, linkFail   ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -154,8 +154,8 @@                 , "the missing library using the -L/path/to/object/dir and -lmissinglibname"                 , "flags, or simply by naming the relevant files on the GHCi command line."                 , "Alternatively, this link failure might indicate a bug in GHCi."-                , "If you suspect the latter, please send a bug report to:"-                , "  glasgow-haskell-bugs@haskell.org"+                , "If you suspect the latter, please report this as a GHC bug:"+                , "  https://www.haskell.org/ghc/reportabug"                 ])
compiler/ghci/Debugger.hs view
@@ -40,7 +40,7 @@ import Exception  import Control.Monad-import Data.List+import Data.List ( (\\) ) import Data.Maybe import Data.IORef @@ -74,11 +74,11 @@    -- Do the obtainTerm--bindSuspensions-computeSubstitution dance    go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term)    go subst id = do-       let id' = id `setIdType` substTy subst (idType id)+       let id_ty' = substTy subst (idType id)+           id'    = id `setIdType` id_ty'        term_    <- GHC.obtainTermFromId maxBound force id'        term     <- tidyTermTyVars term_-       term'    <- if bindThings &&-                      (not (isUnliftedType (termType term)))+       term'    <- if bindThings                      then bindSuspensions term                      else return term      -- Before leaving, we compare the type obtained to see if it's more specific@@ -86,13 +86,14 @@      --  mapping the old tyvars to the reconstructed types.        let reconstructed_type = termType term        hsc_env <- getSession-       case (improveRTTIType hsc_env (idType id) (reconstructed_type)) of+       case (improveRTTIType hsc_env id_ty' reconstructed_type) of          Nothing     -> return (subst, term')          Just subst' -> do { dflags <- GHC.getSessionDynFlags                            ; liftIO $                                dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI"                                  (fsep $ [text "RTTI Improvement for", ppr id,-                                  text "is the substitution:" , ppr subst'])+                                  text "old substitution:" , ppr subst,+                                  text "new substitution:" , ppr subst'])                            ; return (subst `unionTCvSubst` subst', term')}     tidyTermTyVars :: GhcMonad m => Term -> m Term@@ -124,7 +125,8 @@       let ids = [ mkVanillaGlobal name ty                 | (name,ty) <- zip names tys]           new_ic = extendInteractiveContextWithIds ictxt ids-      liftIO $ extendLinkEnv (zip names fhvs)+          dl = hsc_dynLinker hsc_env+      liftIO $ extendLinkEnv dl (zip names fhvs)       setSession hsc_env {hsc_IC = new_ic }       return t'      where@@ -178,8 +180,10 @@                expr = "Prelude.return (Prelude.show " ++                          showPpr dflags bname ++                       ") :: Prelude.IO Prelude.String"+               dl   = hsc_dynLinker hsc_env            _ <- GHC.setSessionDynFlags dflags{log_action=noop_log}-           txt_ <- withExtendedLinkEnv [(bname, fhv)]+           txt_ <- withExtendedLinkEnv dl+                                       [(bname, fhv)]                                        (GHC.compileExprRemote expr)            let myprec = 10 -- application precedence. TODO Infix constructors            txt <- liftIO $ evalString hsc_env txt_
compiler/ghci/GHCi.hs view
@@ -51,7 +51,7 @@ import GhcPrelude  import GHCi.Message-#if defined(GHCI)+#if defined(HAVE_INTERNAL_INTERPRETER) import GHCi.Run #endif import GHCi.RemoteTypes@@ -117,7 +117,7 @@   taking the performance hit on the compiler that profiling would   entail. -For other reasons see RemoteGHCi on the wiki.+For other reasons see remote-GHCi on the wiki.  Implementation Overview ~~~~~~~~~~~~~~~~~~~~~~~@@ -152,12 +152,12 @@ Other Notes on Remote GHCi ~~~~~~~~~~~~~~~~~~~~~~~~~~   * This wiki page has an implementation overview:-    https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/ExternalInterpreter+    https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/external-interpreter   * Note [External GHCi pointers] in compiler/ghci/GHCi.hs   * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs -} -#if !defined(GHCI)+#if !defined(HAVE_INTERNAL_INTERPRETER) needExtInt :: IO a needExtInt = throwIO   (InstallationError "this operation requires -fexternal-interpreter")@@ -175,7 +175,7 @@        uninterruptibleMask_ $ do -- Note [uninterruptibleMask_]          iservCall iserv msg  | otherwise = -- Just run it directly-#if defined(GHCI)+#if defined(HAVE_INTERNAL_INTERPRETER)    run msg #else    needExtInt@@ -391,7 +391,7 @@                writeIORef iservLookupSymbolCache $! addToUFM cache str p                return (Just p)  | otherwise =-#if defined(GHCI)+#if defined(HAVE_INTERNAL_INTERPRETER)    fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str)) #else    needExtInt@@ -642,7 +642,7 @@   | gopt Opt_ExternalInterpreter dflags   = throwIO (InstallationError       "this operation requires -fno-external-interpreter")-#if defined(GHCI)+#if defined(HAVE_INTERNAL_INTERPRETER)   | otherwise   = localRef _r #else
compiler/ghci/Linker.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-} {-# LANGUAGE BangPatterns #-}-{-# OPTIONS_GHC -fno-cse #-}--- -fno-cse is needed for GLOBAL_VAR's to behave properly  -- --  (c) The University of Glasgow 2002-2006@@ -15,11 +13,12 @@                 linkExpr, linkDecls, unload, withExtendedLinkEnv,                 extendLinkEnv, deleteFromLinkEnv,                 extendLoadedPkgs,-                linkPackages,initDynLinker,linkModule,-                linkCmdLineLibs+                linkPackages, initDynLinker, linkModule,+                linkCmdLineLibs,+                uninitializedLinker         ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -38,6 +37,7 @@ import NameEnv import Module import ListSetOps+import LinkerTypes (DynLinker(..), LinkerUnitId, PersistentLinkerState(..)) import DynFlags import BasicTypes import Outputable@@ -48,7 +48,7 @@ import qualified Maybes import UniqDSet import FastString-import Platform+import GHC.Platform import SysTools import FileCleanup @@ -57,7 +57,7 @@  import Data.Char (isSpace) import Data.IORef-import Data.List+import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition) import Data.Maybe import Control.Concurrent.MVar @@ -72,11 +72,6 @@  import Exception --- needed for 2nd stage-#if STAGE >= 2-import Foreign (Ptr)-#endif- {- **********************************************************************                          The Linker's state@@ -85,76 +80,40 @@  {- The persistent linker state *must* match the actual state of the-C dynamic linker at all times, so we keep it in a private global variable.+C dynamic linker at all times. -The global IORef used for PersistentLinkerState actually contains another MVar,-which in turn contains a Maybe PersistentLinkerState. The MVar serves to ensure-mutual exclusion between multiple loaded copies of the GHC library. The Maybe-may be Nothing to indicate that the linker has not yet been initialised.+The MVar used to hold the PersistentLinkerState contains a Maybe+PersistentLinkerState. The MVar serves to ensure mutual exclusion between+multiple loaded copies of the GHC library. The Maybe may be Nothing to+indicate that the linker has not yet been initialised.  The PersistentLinkerState maps Names to actual closures (for interpreted code only), for use during linking. -}-#if STAGE < 2-GLOBAL_VAR_M( v_PersistentLinkerState-            , newMVar Nothing-            , MVar (Maybe PersistentLinkerState))-#else-SHARED_GLOBAL_VAR_M( v_PersistentLinkerState-                   , getOrSetLibHSghcPersistentLinkerState-                   , "getOrSetLibHSghcPersistentLinkerState"-                   , newMVar Nothing-                   , MVar (Maybe PersistentLinkerState))-#endif +uninitializedLinker :: IO DynLinker+uninitializedLinker =+  newMVar Nothing >>= (pure . DynLinker)+ uninitialised :: a uninitialised = panic "Dynamic linker not initialised" -modifyPLS_ :: (PersistentLinkerState -> IO PersistentLinkerState) -> IO ()-modifyPLS_ f = readIORef v_PersistentLinkerState-  >>= flip modifyMVar_ (fmap pure . f . fromMaybe uninitialised)+modifyPLS_ :: DynLinker -> (PersistentLinkerState -> IO PersistentLinkerState) -> IO ()+modifyPLS_ dl f =+  modifyMVar_ (dl_mpls dl) (fmap pure . f . fromMaybe uninitialised) -modifyPLS :: (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a-modifyPLS f = readIORef v_PersistentLinkerState-  >>= flip modifyMVar (fmapFst pure . f . fromMaybe uninitialised)+modifyPLS :: DynLinker -> (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a+modifyPLS dl f =+  modifyMVar (dl_mpls dl) (fmapFst pure . f . fromMaybe uninitialised)   where fmapFst f = fmap (\(x, y) -> (f x, y)) -readPLS :: IO PersistentLinkerState-readPLS = readIORef v_PersistentLinkerState-  >>= fmap (fromMaybe uninitialised) . readMVar+readPLS :: DynLinker -> IO PersistentLinkerState+readPLS dl =+  (fmap (fromMaybe uninitialised) . readMVar) (dl_mpls dl)  modifyMbPLS_-  :: (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO ()-modifyMbPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f--data PersistentLinkerState-   = PersistentLinkerState {--        -- Current global mapping from Names to their true values-        closure_env :: ClosureEnv,--        -- The current global mapping from RdrNames of DataCons to-        -- info table addresses.-        -- When a new Unlinked is linked into the running image, or an existing-        -- module in the image is replaced, the itbl_env must be updated-        -- appropriately.-        itbl_env    :: !ItblEnv,--        -- The currently loaded interpreted modules (home package)-        bcos_loaded :: ![Linkable],--        -- And the currently-loaded compiled modules (home package)-        objs_loaded :: ![Linkable],--        -- The currently-loaded packages; always object code-        -- Held, as usual, in dependency order; though I am not sure if-        -- that is really important-        pkgs_loaded :: ![LinkerUnitId],--        -- we need to remember the name of previous temporary DLL/.so-        -- libraries so we can link them (see #10322)-        temp_sos :: ![(FilePath, String)] }-+  :: DynLinker -> (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO ()+modifyMbPLS_ dl f = modifyMVar_ (dl_mpls dl) f  emptyPLS :: DynFlags -> PersistentLinkerState emptyPLS _ = PersistentLinkerState {@@ -172,22 +131,21 @@   -- explicit list.  See rts/Linker.c for details.   where init_pkgs = map toInstalledUnitId [rtsUnitId] --extendLoadedPkgs :: [InstalledUnitId] -> IO ()-extendLoadedPkgs pkgs =-  modifyPLS_ $ \s ->+extendLoadedPkgs :: DynLinker -> [InstalledUnitId] -> IO ()+extendLoadedPkgs dl pkgs =+  modifyPLS_ dl $ \s ->       return s{ pkgs_loaded = pkgs ++ pkgs_loaded s } -extendLinkEnv :: [(Name,ForeignHValue)] -> IO ()-extendLinkEnv new_bindings =-  modifyPLS_ $ \pls@PersistentLinkerState{..} -> do+extendLinkEnv :: DynLinker -> [(Name,ForeignHValue)] -> IO ()+extendLinkEnv dl new_bindings =+  modifyPLS_ dl $ \pls@PersistentLinkerState{..} -> do     let new_ce = extendClosureEnv closure_env new_bindings     return $! pls{ closure_env = new_ce }     -- strictness is important for not retaining old copies of the pls -deleteFromLinkEnv :: [Name] -> IO ()-deleteFromLinkEnv to_remove =-  modifyPLS_ $ \pls -> do+deleteFromLinkEnv :: DynLinker -> [Name] -> IO ()+deleteFromLinkEnv dl to_remove =+  modifyPLS_ dl $ \pls -> do     let ce = closure_env pls     let new_ce = delListFromNameEnv ce to_remove     return pls{ closure_env = new_ce }@@ -199,8 +157,9 @@ -- Throws a 'ProgramError' if loading fails or the name cannot be found. getHValue :: HscEnv -> Name -> IO ForeignHValue getHValue hsc_env name = do+  let dl = hsc_dynLinker hsc_env   initDynLinker hsc_env-  pls <- modifyPLS $ \pls -> do+  pls <- modifyPLS dl $ \pls -> do            if (isExternalName name) then do              (pls', ok) <- linkDependencies hsc_env pls noSrcSpan                               [nameModule name]@@ -223,7 +182,7 @@                  -> SrcSpan -> [Module]                  -> IO (PersistentLinkerState, SuccessFlag) linkDependencies hsc_env pls span needed_mods = do---   initDynLinker (hsc_dflags hsc_env)+--   initDynLinker (hsc_dflags hsc_env) dl    let hpt = hsc_HPT hsc_env        dflags = hsc_dflags hsc_env    -- The interpreter and dynamic linker can only handle object code built@@ -244,9 +203,9 @@ -- | Temporarily extend the linker state.  withExtendedLinkEnv :: (ExceptionMonad m) =>-                       [(Name,ForeignHValue)] -> m a -> m a-withExtendedLinkEnv new_env action-    = gbracket (liftIO $ extendLinkEnv new_env)+                       DynLinker -> [(Name,ForeignHValue)] -> m a -> m a+withExtendedLinkEnv dl new_env action+    = gbracket (liftIO $ extendLinkEnv dl new_env)                (\_ -> reset_old_env)                (\_ -> action)     where@@ -256,16 +215,16 @@         -- package), so the reset action only removes the names we         -- added earlier.           reset_old_env = liftIO $ do-            modifyPLS_ $ \pls ->+            modifyPLS_ dl $ \pls ->                 let cur = closure_env pls                     new = delListFromNameEnv cur (map fst new_env)                 in return pls{ closure_env = new }   -- | Display the persistent linker state.-showLinkerState :: DynFlags -> IO ()-showLinkerState dflags-  = do pls <- readPLS+showLinkerState :: DynLinker -> DynFlags -> IO ()+showLinkerState dl dflags+  = do pls <- readPLS dl        putLogMsg dflags NoReason SevDump noSrcSpan           (defaultDumpStyle dflags)                  (vcat [text "----- Linker state -----",@@ -299,8 +258,9 @@ -- trying to link. -- initDynLinker :: HscEnv -> IO ()-initDynLinker hsc_env =-  modifyMbPLS_ $ \pls -> do+initDynLinker hsc_env = do+  let dl = hsc_dynLinker hsc_env+  modifyMbPLS_ dl $ \pls -> do     case pls of       Just  _ -> return pls       Nothing -> Just <$> reallyInitDynLinker hsc_env@@ -323,8 +283,9 @@  linkCmdLineLibs :: HscEnv -> IO () linkCmdLineLibs hsc_env = do+  let dl = hsc_dynLinker hsc_env   initDynLinker hsc_env-  modifyPLS_ $ \pls -> do+  modifyPLS_ dl $ \pls -> do     linkCmdLineLibs' hsc_env pls  linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState@@ -341,7 +302,7 @@       -- However because we don't know the actual name of pthread's dll we       -- need to defer this to the locateLib call so we can't initialize it       -- inside of the rts. Instead we do it here to be able to find the-      -- import library for pthreads. See Trac #13210.+      -- import library for pthreads. See #13210.       let platform = targetPlatform dflags           os       = platformOS platform           minus_ls = case os of@@ -380,7 +341,7 @@        -- Add directories to library search paths, this only has an effect       -- on Windows. On Unix OSes this function is a NOP.-      let all_paths = let paths = takeDirectory (fst $ sPgm_c $ settings dflags)+      let all_paths = let paths = takeDirectory (pgm_c dflags)                                 : framework_paths                                ++ lib_paths_base                                ++ [ takeDirectory dll | DLLPath dll <- libspecs ]@@ -563,8 +524,11 @@      -- Initialise the linker (if it's not been done already)    ; initDynLinker hsc_env +     -- Extract the DynLinker value for passing into required places+   ; let dl = hsc_dynLinker hsc_env+      -- Take lock for the actual work.-   ; modifyPLS $ \pls0 -> do {+   ; modifyPLS dl $ \pls0 -> do {       -- Link the packages and modules required    ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods@@ -793,8 +757,11 @@     -- Initialise the linker (if it's not been done already)     initDynLinker hsc_env +    -- Extract the DynLinker for passing into required places+    let dl = hsc_dynLinker hsc_env+     -- Take lock for the actual work.-    modifyPLS $ \pls0 -> do+    modifyPLS dl $ \pls0 -> do      -- Link the packages and modules required     (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods@@ -835,7 +802,8 @@ linkModule :: HscEnv -> Module -> IO () linkModule hsc_env mod = do   initDynLinker hsc_env-  modifyPLS_ $ \pls -> do+  let dl = hsc_dynLinker hsc_env+  modifyPLS_ dl $ \pls -> do     (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod]     if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module")       else return pls'@@ -926,8 +894,8 @@  dynLoadObjs :: HscEnv -> PersistentLinkerState -> [FilePath]             -> IO PersistentLinkerState-dynLoadObjs _       pls []   = return pls-dynLoadObjs hsc_env pls objs = do+dynLoadObjs _       pls                           []   = return pls+dynLoadObjs hsc_env pls@PersistentLinkerState{..} objs = do     let dflags = hsc_dflags hsc_env     let platform = targetPlatform dflags     let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ]@@ -944,13 +912,13 @@                       -- library.                       ldInputs =                            concatMap (\l -> [ Option ("-l" ++ l) ])-                                     (nub $ snd <$> temp_sos pls)+                                     (nub $ snd <$> temp_sos)                         ++ concatMap (\lp -> [ Option ("-L" ++ lp)                                                     , Option "-Xlinker"                                                     , Option "-rpath"                                                     , Option "-Xlinker"                                                     , Option lp ])-                                     (nub $ fst <$> temp_sos pls)+                                     (nub $ fst <$> temp_sos)                         ++ concatMap                              (\lp ->                                  [ Option ("-L" ++ lp)@@ -978,13 +946,13 @@     -- link all "loaded packages" so symbols in those can be resolved     -- Note: We are loading packages with local scope, so to see the     -- symbols in this link we must link all loaded packages again.-    linkDynLib dflags2 objs (pkgs_loaded pls)+    linkDynLib dflags2 objs pkgs_loaded      -- if we got this far, extend the lifetime of the library file     changeTempFilesLifetime dflags TFL_GhcSession [soFile]     m <- loadDLL hsc_env soFile     case m of-        Nothing -> return pls { temp_sos = (libPath, libName) : temp_sos pls }+        Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos }         Just err -> panic ("Loading temp shared object failed: " ++ err)  rmDupLinkables :: [Linkable]    -- Already loaded@@ -1099,8 +1067,11 @@         -- Initialise the linker (if it's not been done already)         initDynLinker hsc_env +        -- Extract DynLinker for passing into required places+        let dl = hsc_dynLinker hsc_env+         new_pls-            <- modifyPLS $ \pls -> do+            <- modifyPLS dl $ \pls -> do                  pls1 <- unload_wkr hsc_env linkables pls                  return (pls1, pls1) @@ -1165,7 +1136,10 @@         -- We don't do any cleanup when linking objects with the         -- dynamic linker.  Doing so introduces extra complexity for         -- not much benefit.-      | otherwise++      -- Code unloading currently disabled due to instability.+      -- See #16841.+      | False -- otherwise       = mapM_ (unloadObj hsc_env) [f | DotO f <- linkableUnlinked lnk]                 -- The components of a BCO linkable may contain                 -- dot-o files.  Which is very confusing.@@ -1173,6 +1147,7 @@                 -- But the BCO parts can be unlinked just by                 -- letting go of them (plus of course depopulating                 -- the symbol table which is done in the main body)+      | otherwise = return () -- see #16841  {- ********************************************************************** @@ -1201,6 +1176,13 @@     | Framework String   -- Only used for darwin, but does no harm +instance Outputable LibrarySpec where+  ppr (Objects objs) = text "Objects" <+> ppr objs+  ppr (Archive a) = text "Archive" <+> text a+  ppr (DLL s) = text "DLL" <+> text s+  ppr (DLLPath f) = text "DLLPath" <+> text f+  ppr (Framework s) = text "Framework" <+> text s+ -- If this package is already part of the GHCi binary, we'll already -- have the right DLLs for this package loaded, so don't try to -- load them again.@@ -1223,9 +1205,6 @@ showLS (DLLPath nm)   = "(dynamic) " ++ nm showLS (Framework nm) = "(framework) " ++ nm --- TODO: Make this type more precise-type LinkerUnitId = InstalledUnitId- -- | Link exactly the specified packages, and their dependents (unless of -- course they are already linked).  The dependents are linked -- automatically, and it doesn't matter what order you specify the input@@ -1244,7 +1223,8 @@   -- It's probably not safe to try to load packages concurrently, so we take   -- a lock.   initDynLinker hsc_env-  modifyPLS_ $ \pls -> do+  let dl = hsc_dynLinker hsc_env+  modifyPLS_ dl $ \pls -> do     linkPackages' hsc_env new_pkgs pls  linkPackages' :: HscEnv -> [LinkerUnitId] -> PersistentLinkerState@@ -1549,10 +1529,25 @@                         in apply (map implib import_libs)                        _         -> return Nothing -     assumeDll   = return (DLL lib)+     -- TH Makes use of the interpreter so this failure is not obvious.+     -- So we are nice and warn/inform users why we fail before we do.+     -- But only for haskell libraries, as C libraries don't have a+     -- profiling/non-profiling distinction to begin with.+     assumeDll+      | is_hs+      , not loading_dynamic_hs_libs+      , interpreterProfiled dflags+      = do+          warningMsg dflags+            (text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$+              text " \tTrying dynamic library instead. If this fails try to rebuild" <+>+              text "libraries with profiling support.")+          return (DLL lib)+      | otherwise = return (DLL lib)      infixr `orElse`      f `orElse` g = f >>= maybe g return +     apply :: [IO (Maybe a)] -> IO (Maybe a)      apply []     = return Nothing      apply (x:xs) = do x' <- x                        if isJust x'
compiler/ghci/RtClosureInspect.hs view
@@ -23,7 +23,7 @@      constrClosToName -- exported to use in test T4891  ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -62,7 +62,7 @@  import Control.Monad import Data.Maybe-import Data.List+import Data.List ((\\)) #if defined(INTEGER_GMP) import GHC.Exts import Data.Array.Base@@ -752,9 +752,9 @@          traceTR (text "Following a MutVar")          contents_tv <- newVar liftedTypeKind          MASSERT(isUnliftedType my_ty)-         (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy+         (mutvar_ty,_) <- instScheme $ quantifyType $ mkVisFunTy                             contents_ty (mkTyConApp tycon [world,contents_ty])-         addConstraint (mkFunTy contents_tv my_ty) mutvar_ty+         addConstraint (mkVisFunTy contents_tv my_ty) mutvar_ty          x <- go (pred max_depth) contents_tv contents_ty contents          return (RefWrap my_ty x) @@ -856,7 +856,7 @@       | otherwise = do           -- This is a bit involved since we allow packing multiple fields           -- within a single word. See also-          -- StgCmmLayout.mkVirtHeapOffsetsWithPadding+          -- GHC.StgToCmm.Layout.mkVirtHeapOffsetsWithPadding           dflags <- getDynFlags           let word_size = wORD_SIZE dflags               big_endian = wORDS_BIGENDIAN dflags@@ -864,7 +864,7 @@               -- Align the start offset (eg, 2-byte value should be 2-byte               -- aligned). But not more than to a word. The offset calculation               -- should be the same with the offset calculation in-              -- StgCmmLayout.mkVirtHeapOffsetsWithPadding.+              -- GHC.StgToCmm.Layout.mkVirtHeapOffsetsWithPadding.               !aligned_idx = roundUpTo arr_i (min word_size size_b)               !new_arr_i = aligned_idx + size_b               ws | size_b < word_size =@@ -1056,7 +1056,7 @@  {- Note [Constructor arg types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider a GADT (cf Trac #7386)+Consider a GADT (cf #7386)    data family D a b    data instance D [a] a where      MkT :: a -> D [a] (Maybe a)@@ -1259,7 +1259,7 @@     , Just (r1,r2) <- splitFunTy_maybe r     = do r2' <- go l2 r2          r1' <- go l1 r1-         return (mkFunTy r1' r2')+         return (mkVisFunTy r1' r2') -- TyconApp Inductive case; this is the interesting bit.     | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs     , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
compiler/hieFile/HieAst.hs view
@@ -25,18 +25,20 @@ import ConLike                    ( conLikeName ) import Desugar                    ( deSugarExpr ) import FieldLabel-import HsSyn+import GHC.Hs import HscTypes import Module                     ( ModuleName, ml_hs_file ) import MonadUtils                 ( concatMapM, liftIO ) import Name                       ( Name, nameSrcSpan, setNameLoc )+import NameEnv                    ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) import SrcLoc import TcHsSyn                    ( hsLitType, hsPatType )-import Type                       ( mkFunTys, Type )+import Type                       ( mkVisFunTys, Type ) import TysWiredIn                 ( mkListTy, mkSumTy ) import Var                        ( Id, Var, setVarName, varName, varType ) import TcRnTypes import MkIface                    ( mkIfaceExports )+import Panic  import HieTypes import HieUtils@@ -51,6 +53,134 @@ import Control.Monad.Trans.Reader import Control.Monad.Trans.Class  ( lift ) +{- Note [Updating HieAst for changes in the GHC AST]++When updating the code in this file for changes in the GHC AST, you+need to pay attention to the following things:++1) Symbols (Names/Vars/Modules) in the following categories:++   a) Symbols that appear in the source file that directly correspond to+   something the user typed+   b) Symbols that don't appear in the source, but should be in some sense+   "visible" to a user, particularly via IDE tooling or the like. This+   includes things like the names introduced by RecordWildcards (We record+   all the names introduced by a (..) in HIE files), and will include implicit+   parameters and evidence variables after one of my pending MRs lands.++2) Subtrees that may contain such symbols, or correspond to a SrcSpan in+   the file. This includes all `Located` things++For 1), you need to call `toHie` for one of the following instances++instance ToHie (Context (Located Name)) where ...+instance ToHie (Context (Located Var)) where ...+instance ToHie (IEContext (Located ModuleName)) where ...++`Context` is a data type that looks like:++data Context a = C ContextInfo a -- Used for names and bindings++`ContextInfo` is defined in `HieTypes`, and looks like++data ContextInfo+  = Use                -- ^ regular variable+  | MatchBind+  | IEThing IEType     -- ^ import/export+  | TyDecl+  -- | Value binding+  | ValBind+      BindType     -- ^ whether or not the binding is in an instance+      Scope        -- ^ scope over which the value is bound+      (Maybe Span) -- ^ span of entire binding+  ...++It is used to annotate symbols in the .hie files with some extra information on+the context in which they occur and should be fairly self explanatory. You need+to select one that looks appropriate for the symbol usage. In very rare cases,+you might need to extend this sum type if none of the cases seem appropriate.++So, given a `Located Name` that is just being "used", and not defined at a+particular location, you would do the following:++   toHie $ C Use located_name++If you select one that corresponds to a binding site, you will need to+provide a `Scope` and a `Span` for your binding. Both of these are basically+`SrcSpans`.++The `SrcSpan` in the `Scope` is supposed to span over the part of the source+where the symbol can be legally allowed to occur. For more details on how to+calculate this, see Note [Capturing Scopes and other non local information]+in HieAst.++The binding `Span` is supposed to be the span of the entire binding for+the name.++For a function definition `foo`:++foo x = x + y+  where y = x^2++The binding `Span` is the span of the entire function definition from `foo x`+to `x^2`.  For a class definition, this is the span of the entire class, and+so on.  If this isn't well defined for your bit of syntax (like a variable+bound by a lambda), then you can just supply a `Nothing`++There is a test that checks that all symbols in the resulting HIE file+occur inside their stated `Scope`. This can be turned on by passing the+-fvalidate-ide-info flag to ghc along with -fwrite-ide-info to generate the+.hie file.++You may also want to provide a test in testsuite/test/hiefile that includes+a file containing your new construction, and tests that the calculated scope+is valid (by using -fvalidate-ide-info)++For subtrees in the AST that may contain symbols, the procedure is fairly+straightforward.  If you are extending the GHC AST, you will need to provide a+`ToHie` instance for any new types you may have introduced in the AST.++Here are is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)):++  toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of+      HsVar _ (L _ var) ->+        [ toHie $ C Use (L mspan var)+             -- Patch up var location since typechecker removes it+        ]+      HsConLikeOut _ con ->+        [ toHie $ C Use $ L mspan $ conLikeName con+        ]+      ...+      HsApp _ a b ->+        [ toHie a+        , toHie b+        ]++If your subtree is `Located` or has a `SrcSpan` available, the output list+should contain a HieAst `Node` corresponding to the subtree. You can use+either `makeNode` or `getTypeNode` for this purpose, depending on whether it+makes sense to assign a `Type` to the subtree. After this, you just need+to concatenate the result of calling `toHie` on all subexpressions and+appropriately annotated symbols contained in the subtree.++The code above from the ToHie instance of `LhsExpr (GhcPass p)` is supposed+to work for both the renamed and typechecked source. `getTypeNode` is from+the `HasType` class defined in this file, and it has different instances+for `GhcTc` and `GhcRn` that allow it to access the type of the expression+when given a typechecked AST:++class Data a => HasType a where+  getTypeNode :: a -> HieM [HieAST Type]+instance HasType (LHsExpr GhcTc) where+  getTypeNode e@(L spn e') = ... -- Actually get the type for this expression+instance HasType (LHsExpr GhcRn) where+  getTypeNode (L spn e) = makeNode e spn -- Fallback to a regular `makeNode` without recording the type++If your subtree doesn't have a span available, you can omit the `makeNode`+call and just recurse directly in to the subexpressions.++-}+ -- These synonyms match those defined in main/GHC.hs type RenamedSource     = ( HsGroup GhcRn, [LImportDecl GhcRn]                          , Maybe [(LIE GhcRn, Avails)]@@ -64,11 +194,11 @@ so we replace all occurrences of the mono name with the poly name. -} newtype HieState = HieState-  { name_remapping :: M.Map Name Id+  { name_remapping :: NameEnv Id   }  initState :: HieState-initState = HieState M.empty+initState = HieState emptyNameEnv  class ModifyState a where -- See Note [Name Remapping]   addSubstitution :: a -> a -> HieState -> HieState@@ -78,7 +208,7 @@  instance ModifyState Id where   addSubstitution mono poly hs =-    hs{name_remapping = M.insert (varName mono) poly (name_remapping hs)}+    hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly}  modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState modifyState = foldr go id@@ -160,7 +290,7 @@  grhss_span :: GRHSs p body -> SrcSpan grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)-grhss_span (XGRHSs _) = error "XGRHS has no span"+grhss_span (XGRHSs _) = panic "XGRHS has no span"  bindingsOnly :: [Context Name] -> [HieAST a] bindingsOnly [] = []@@ -244,7 +374,7 @@   -> [LPat (GhcPass p)]   -> [PScoped (LPat (GhcPass p))] patScopes rsp useScope patScope xs =-  map (\(RS sc a) -> PS rsp useScope sc (unLoc a)) $+  map (\(RS sc a) -> PS rsp useScope sc (composeSrcSpan a)) $     listScopes patScope (map dL xs)  -- | 'listScopes' specialised to 'TVScoped' things@@ -282,7 +412,7 @@   ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs                                                 GhcRn                                                 (Shielded (LHsType GhcRn)))-  ProtectedSig GhcTc = NoExt+  ProtectedSig GhcTc = NoExtField  class ProtectSig a where   protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a@@ -294,12 +424,13 @@   toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)  instance ProtectSig GhcTc where-  protectSig _ _ = NoExt+  protectSig _ _ = noExtField  instance ProtectSig GhcRn where   protectSig sc (HsWC a (HsIB b sig)) =     HsWC a (HsIB b (SH sc sig))-  protectSig _ _ = error "protectSig not given HsWC (HsIB)"+  protectSig _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec+  protectSig _ (XHsWildCardBndrs nec) = noExtCon nec  class HasLoc a where   -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can@@ -331,7 +462,7 @@   loc [] = noSrcSpan   loc xs = foldl1' combineSrcSpans $ map loc xs -instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where+instance HasLoc a => HasLoc (FamEqn s a) where   loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]   loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans                                               [loc a, loc tvs, loc b, loc c]@@ -347,10 +478,24 @@     -- Most probably the rest will be unhelpful anyway   loc _ = noSrcSpan -instance HasLoc (Pat (GhcPass a)) where-  loc (dL -> L l _) = l+{- Note [Real DataCon Name]+The typechecker subtitutes the conLikeWrapId for the name, but we don't want+this showing up in the hieFile, so we replace the name in the Id with the+original datacon name+See also Note [Data Constructor Naming]+-}+class HasRealDataConName p where+  getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p) +instance HasRealDataConName GhcRn where+  getRealDataCon _ n = n+instance HasRealDataConName GhcTc where+  getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) =+    L sp (setVarName var (conLikeName con))+ -- | The main worker class+-- See Note [Updating HieAst for changes in the GHC AST] for more information+-- on how to add/modify instances for this. class ToHie a where   toHie :: a -> HieM [HieAST Type] @@ -367,10 +512,10 @@ instance (ToHie a) => ToHie (Maybe a) where   toHie = maybe (pure []) toHie -instance ToHie (Context (Located NoExt)) where+instance ToHie (Context (Located NoExtField)) where   toHie _ = pure [] -instance ToHie (TScoped NoExt) where+instance ToHie (TScoped NoExtField) where   toHie _ = pure []  instance ToHie (IEContext (Located ModuleName)) where@@ -385,7 +530,9 @@       C context (L (RealSrcSpan span) name')         -> do         m <- asks name_remapping-        let name = M.findWithDefault name' (varName name') m+        let name = case lookupNameEnv m (varName name') of+              Just var -> var+              Nothing-> name'         pure           [Node             (NodeInfo S.empty [] $@@ -400,7 +547,7 @@   toHie c = case c of       C context (L (RealSrcSpan span) name') -> do         m <- asks name_remapping-        let name = case M.lookup name' m of+        let name = case lookupNameEnv m name' of               Just var -> varName var               Nothing -> name'         pure@@ -431,10 +578,10 @@       FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)       _ -> makeNode bind spn -instance HasType (LPat GhcRn) where+instance HasType (Located (Pat GhcRn)) where   getTypeNode (dL -> L spn pat) = makeNode pat spn -instance HasType (LPat GhcTc) where+instance HasType (Located (Pat GhcTc)) where   getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)  instance HasType (LHsExpr GhcRn) where@@ -475,7 +622,9 @@      in     case tyOpt of-      _ | skipDesugaring e' -> fallback+      Just t -> makeTypeNode e' spn t+      Nothing+        | skipDesugaring e' -> fallback         | otherwise -> do             hs_env <- Hsc $ \e w -> return (e,w)             (_,mbe) <- liftIO $ deSugarExpr hs_env e@@ -484,7 +633,7 @@       fallback = makeNode e' spn        matchGroupType :: MatchGroupTc -> Type-      matchGroupType (MatchGroupTc args res) = mkFunTys args res+      matchGroupType (MatchGroupTc args res) = mkVisFunTys args res        -- | Skip desugaring of these expressions for performance reasons.       --@@ -616,7 +765,7 @@          , ToHie (TScoped (ProtectedSig a))          , HasType (LPat a)          , Data (HsSplice a)-         ) => ToHie (PScoped (LPat (GhcPass p))) where+         ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where   toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) =     concatM $ getTypeNode lpat : case opat of       WildPat _ ->@@ -732,6 +881,7 @@          , Data (HsSplice a)          , Data (HsTupArg a)          , Data (AmbiguousFieldOcc a)+         , (HasRealDataConName a)          ) => ToHie (LHsExpr (GhcPass p)) where   toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of       HsVar _ (L _ var) ->@@ -812,8 +962,9 @@       ExplicitList _ _ exprs ->         [ toHie exprs         ]-      RecordCon {rcon_con_name = name, rcon_flds = binds}->-        [ toHie $ C Use name+      RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} ->+        [ toHie $ C Use (getRealDataCon @a mrealcon name)+            -- See Note [Real DataCon Name]         , toHie $ RC RecFieldAssign $ binds         ]       RecordUpd {rupd_expr = expr, rupd_flds = upds}->@@ -840,14 +991,6 @@       HsStatic _ expr ->         [ toHie expr         ]-      HsArrApp _ a b _ _ ->-        [ toHie a-        , toHie b-        ]-      HsArrForm _ expr _ cmds ->-        [ toHie expr-        , toHie cmds-        ]       HsTick _ _ expr ->         [ toHie expr         ]@@ -874,18 +1017,6 @@       HsSpliceE _ x ->         [ toHie $ L mspan x         ]-      EWildPat _ -> []-      EAsPat _ a b ->-        [ toHie $ C Use a-        , toHie b-        ]-      EViewPat _ a b ->-        [ toHie a-        , toHie b-        ]-      ELazyPat _ a ->-        [ toHie a-        ]       XExpr _ -> []  instance ( a ~ GhcPass p@@ -1043,7 +1174,7 @@          , Data (StmtLR a a (Located (HsExpr a)))          , Data (HsLocalBinds a)          ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where-  toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM+  toHie (RS sc (ApplicativeArgOne _ pat expr _ _)) = concatM     [ toHie $ PS Nothing sc NoScope pat     , toHie expr     ]@@ -1120,8 +1251,13 @@       XCmd _ -> []  instance ToHie (TyClGroup GhcRn) where-  toHie (TyClGroup _ classes roles instances) = concatM+  toHie TyClGroup{ group_tyclds = classes+                 , group_roles  = roles+                 , group_kisigs = sigs+                 , group_instds = instances } =+    concatM     [ toHie classes+    , toHie sigs     , toHie roles     , toHie instances     ]@@ -1165,18 +1301,12 @@         , toHie $ fmap (BC InstanceBind ModuleScope) meths         , toHie typs         , concatMapM (pure . locOnly . getLoc) deftyps-        , toHie $ map (go . unLoc) deftyps+        , toHie deftyps         ]         where           context_scope = mkLScope context           rhs_scope = foldl1' combineScopes $ map mkScope             [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]--          go :: TyFamDefltEqn GhcRn-             -> FamEqn GhcRn (TScoped (LHsQTyVars GhcRn)) (LHsType GhcRn)-          go (FamEqn a var bndrs pat b rhs) =-             FamEqn a var bndrs (TS (ResolvedScopes [mkLScope rhs]) pat) b rhs-          go (XFamEqn NoExt) = XFamEqn NoExt       XTyClDecl _ -> []  instance ToHie (LFamilyDecl GhcRn) where@@ -1222,15 +1352,12 @@     , toHie $ map (C Use) rhs     ] -instance (ToHie pats, ToHie rhs, HasLoc pats, HasLoc rhs)-    => ToHie (TScoped (FamEqn GhcRn pats rhs)) where+instance (ToHie rhs, HasLoc rhs)+    => ToHie (TScoped (FamEqn GhcRn rhs)) where   toHie (TS _ f) = toHie f -instance ( ToHie pats-         , ToHie rhs-         , HasLoc pats-         , HasLoc rhs-         ) => ToHie (FamEqn GhcRn pats rhs) where+instance (ToHie rhs, HasLoc rhs)+    => ToHie (FamEqn GhcRn rhs) where   toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $     [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var     , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs@@ -1341,6 +1468,17 @@     where span = loc a   toHie (TS _ (XHsWildCardBndrs _)) = pure [] +instance ToHie (LStandaloneKindSig GhcRn) where+  toHie (L sp sig) = concatM [makeNode sig sp, toHie sig]++instance ToHie (StandaloneKindSig GhcRn) where+  toHie sig = concatM $ case sig of+    StandaloneKindSig _ name typ ->+      [ toHie $ C TyDecl name+      , toHie $ TS (ResolvedScopes []) typ+      ]+    XStandaloneKindSig _ -> []+ instance ToHie (SigContext (LSig GhcRn)) where   toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of       TypeSig _ names typ ->@@ -1390,7 +1528,7 @@  instance ToHie (TScoped (LHsType GhcRn)) where   toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of-      HsForAllTy _ bndrs body ->+      HsForAllTy _ _ bndrs body ->         [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs         , toHie body         ]@@ -1478,7 +1616,7 @@       XTyVarBndr _ -> []  instance ToHie (TScoped (LHsQTyVars GhcRn)) where-  toHie (TS sc (HsQTvs (HsQTvsRn implicits _) vars)) = concatM $+  toHie (TS sc (HsQTvs implicits vars)) = concatM $     [ pure $ bindingsOnly bindings     , toHie $ tvScopes sc NoScope vars     ]
compiler/hieFile/HieBin.hs view
@@ -2,8 +2,10 @@ Binary serialization for .hie files. -} {-# LANGUAGE ScopedTypeVariables #-}-module HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic) where+module HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic, hieNameOcc) where +import GHC.Settings               ( maybeRead )+ import Config                     ( cProjectVersion ) import GhcPrelude import Binary@@ -17,7 +19,6 @@ import PrelInfo import SrcLoc import UniqSupply                 ( takeUniqFromSupply )-import Util                       ( maybeRead ) import Unique import UniqFM @@ -57,6 +58,15 @@   ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp   ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp   ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u++hieNameOcc :: HieName -> OccName+hieNameOcc (ExternalName _ occ _) = occ+hieNameOcc (LocalName occ _) = occ+hieNameOcc (KnownKeyName u) =+  case lookupKnownKeyName u of+    Just n -> nameOccName n+    Nothing -> pprPanic "hieNameOcc:unknown known-key unique"+                        (ppr (unpkUnique u))   data HieSymbolTable = HieSymbolTable
compiler/hieFile/HieDebug.hs view
@@ -16,6 +16,7 @@ import HieTypes import HieBin import HieUtils+import Name  import qualified Data.Map as M import qualified Data.Set as S@@ -56,20 +57,30 @@ diffFile :: Diff HieFile diffFile = diffAsts eqDiff `on` (getAsts . hie_asts) -diffAsts :: (Outputable a, Eq a) => Diff a -> Diff (M.Map FastString (HieAST a))+diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (M.Map FastString (HieAST a)) diffAsts f = diffList (diffAst f) `on` M.elems -diffAst :: (Outputable a, Eq a) => Diff a -> Diff (HieAST a)+diffAst :: (Outputable a, Eq a,Ord a) => Diff a -> Diff (HieAST a) diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) =     infoDiff ++ spanDiff ++ diffList (diffAst diffType) xs1 xs2   where     spanDiff       | span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]]       | otherwise = []-    infoDiff+    infoDiff'       = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) info1 info2      ++ (diffList diffType `on` nodeType) info1 info2      ++ (diffIdents `on` nodeIdentifiers) info1 info2+    infoDiff = case infoDiff' of+      [] -> []+      xs -> xs ++ [vcat ["In Node:",ppr (nodeIdentifiers info1,span1)+                           , "and", ppr (nodeIdentifiers info2,span2)+                        , "While comparing"+                        , ppr (normalizeIdents $ nodeIdentifiers info1), "and"+                        , ppr (normalizeIdents $ nodeIdentifiers info2)+                        ]+                  ]+     diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b     diffIdent (a,b) (c,d) = diffName a c                          ++ eqDiff b d@@ -81,10 +92,11 @@  type DiffIdent = Either ModuleName HieName -normalizeIdents :: NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)]-normalizeIdents = sortOn fst . map (first toHieName) . M.toList+normalizeIdents :: Ord a => NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)]+normalizeIdents = sortOn go . map (first toHieName) . M.toList   where     first f (a,b) = (fmap f a, b)+    go (a,b) = (hieNameOcc <$> a,identInfo b,identType b)  diffList :: Diff a -> Diff [a] diffList f xs ys@@ -122,10 +134,14 @@  -- | Look for any identifiers which occur outside of their supposed scopes. -- Returns a list of error messages.-validateScopes :: M.Map FastString (HieAST a) -> [SDoc]-validateScopes asts = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap+validateScopes :: Module -> M.Map FastString (HieAST a) -> [SDoc]+validateScopes mod asts = validScopes   where     refMap = generateReferencesMap asts+    -- We use a refmap for most of the computation++    -- Check if all the names occur in their calculated scopes+    validScopes = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap     valid (Left _) _ = []     valid (Right n) refs = concatMap inScope refs       where@@ -134,13 +150,22 @@           Just xs -> xs           Nothing -> []         inScope (sp, dets)-          |  definedInAsts asts n+          |  (definedInAsts asts n)           && any isOccurrence (identInfo dets)+          -- We validate scopes for names which are defined locally, and occur+          -- in this span             = case scopes of-              [] -> []+              [] | (nameIsLocalOrFrom mod n+                   && not (isDerivedOccName $ nameOccName n))+                   -- If we don't get any scopes for a local name then its an error.+                   -- We can ignore derived names.+                   -> return $ hsep $+                     [ "Locally defined Name", ppr n,pprDefinedAt n , "at position", ppr sp+                     , "Doesn't have a calculated scope: ", ppr scopes]+                 | otherwise -> []               _ -> if any (`scopeContainsSpan` sp) scopes                    then []                    else return $ hsep $-                     [ "Name", ppr n, "at position", ppr sp+                     [ "Name", ppr n, pprDefinedAt n, "at position", ppr sp                      , "doesn't occur in calculated scope", ppr scopes]           | otherwise = []
compiler/hieFile/HieUtils.hs view
@@ -63,7 +63,7 @@       where         ts' = go (extendTvSubst env tv t) res ts -    go env (FunTy _ res) (t:ts) -- No type-class args in tycon apps+    go env (FunTy { ft_res = res }) (t:ts) -- No type-class args in tycon apps       = (True,t) : (go env res ts)      go env (TyVarTy tv) ts@@ -81,8 +81,8 @@     go (HLitTy l) = IfaceLitTy l     go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k)                                   in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t-    go (HFunTy a b) = IfaceFunTy a b-    go (HQualTy pred b) = IfaceDFunTy pred b+    go (HFunTy a b)     = IfaceFunTy VisArg   a    b+    go (HQualTy pred b) = IfaceFunTy InvisArg pred b     go (HCastTy a) = a     go HCoercionTy = IfaceTyVar "<coercion type>"     go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)@@ -158,12 +158,12 @@       k <- getTypeIndex (varType v)       i <- getTypeIndex t       return $ HForAllTy ((varName v,k),a) i-    go (FunTy a b) = do+    go (FunTy { ft_af = af, ft_arg = a, ft_res = b }) = do       ai <- getTypeIndex a       bi <- getTypeIndex b-      return $ if isPredTy a-                  then HQualTy ai bi-                  else HFunTy ai bi+      return $ case af of+                 InvisArg -> HQualTy ai bi+                 VisArg   -> HFunTy ai bi     go (LitTy a) = return $ HLitTy $ toIfaceTyLit a     go (CastTy t _) = do       i <- getTypeIndex t
− compiler/hsSyn/Convert.hs 
@@ -1,1973 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---This module converts Template Haskell syntax into HsSyn--}--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--module Convert( convertToHsExpr, convertToPat, convertToHsDecls,-                convertToHsType,-                thRdrNameGuesses ) where--import GhcPrelude--import HsSyn as Hs-import PrelNames-import RdrName-import qualified Name-import Module-import RdrHsSyn-import OccName-import SrcLoc-import Type-import qualified Coercion ( Role(..) )-import TysWiredIn-import BasicTypes as Hs-import ForeignCall-import Unique-import ErrUtils-import Bag-import Lexeme-import Util-import FastString-import Outputable-import MonadUtils ( foldrM )--import qualified Data.ByteString as BS-import Control.Monad( unless, liftM, ap )--import Data.Maybe( catMaybes, isNothing )-import Language.Haskell.TH as TH hiding (sigP)-import Language.Haskell.TH.Syntax as TH------------------------------------------------------------------------              The external interface--convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]-convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds))-  where-    cvt_dec d = wrapMsg "declaration" d (cvtDec d)--convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs)-convertToHsExpr loc e-  = initCvt loc $ wrapMsg "expression" e $ cvtl e--convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs)-convertToPat loc p-  = initCvt loc $ wrapMsg "pattern" p $ cvtPat p--convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs)-convertToHsType loc t-  = initCvt loc $ wrapMsg "type" t $ cvtType t----------------------------------------------------------------------newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }-        -- Push down the source location;-        -- Can fail, with a single error message---- NB: If the conversion succeeds with (Right x), there should---     be no exception values hiding in x--- Reason: so a (head []) in TH code doesn't subsequently---         make GHC crash when it tries to walk the generated tree---- Use the loc everywhere, for lack of anything better--- In particular, we want it on binding locations, so that variables bound in--- the spliced-in declarations get a location that at least relates to the splice point--instance Functor CvtM where-    fmap = liftM--instance Applicative CvtM where-    pure x = CvtM $ \loc -> Right (loc,x)-    (<*>) = ap--instance Monad CvtM where-  (CvtM m) >>= k = CvtM $ \loc -> case m loc of-                                  Left err -> Left err-                                  Right (loc',v) -> unCvtM (k v) loc'--initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a-initCvt loc (CvtM m) = fmap snd (m loc)--force :: a -> CvtM ()-force a = a `seq` return ()--failWith :: MsgDoc -> CvtM a-failWith m = CvtM (\_ -> Left m)--getL :: CvtM SrcSpan-getL = CvtM (\loc -> Right (loc,loc))--setL :: SrcSpan -> CvtM ()-setL loc = CvtM (\_ -> Right (loc, ()))--returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a-returnL x = CvtM (\loc -> Right (loc, cL loc x))--returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)-returnJustL = fmap Just . returnL--wrapParL :: HasSrcSpan a =>-            (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess  a)-wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (cL loc x)))--wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b--- E.g  wrapMsg "declaration" dec thing-wrapMsg what item (CvtM m)-  = CvtM (\loc -> case m loc of-                     Left err -> Left (err $$ getPprStyle msg)-                     Right v  -> Right v)-  where-        -- Show the item in pretty syntax normally,-        -- but with all its constructors if you say -dppr-debug-    msg sty = hang (text "When splicing a TH" <+> text what <> colon)-                 2 (if debugStyle sty-                    then text (show item)-                    else text (pprint item))--wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a-wrapL (CvtM m) = CvtM (\loc -> case m loc of-                               Left err -> Left err-                               Right (loc',v) -> Right (loc',cL loc v))----------------------------------------------------------------------cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]-cvtDecs = fmap catMaybes . mapM cvtDec--cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs))-cvtDec (TH.ValD pat body ds)-  | TH.VarP s <- pat-  = do  { s' <- vNameL s-        ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)-        ; returnJustL $ Hs.ValD noExt $ mkFunBind s' [cl'] }--  | otherwise-  = do  { pat' <- cvtPat pat-        ; body' <- cvtGuard body-        ; ds' <- cvtLocalDecs (text "a where clause") ds-        ; returnJustL $ Hs.ValD noExt $-          PatBind { pat_lhs = pat'-                  , pat_rhs = GRHSs noExt body' (noLoc ds')-                  , pat_ext = noExt-                  , pat_ticks = ([],[]) } }--cvtDec (TH.FunD nm cls)-  | null cls-  = failWith (text "Function binding for"-                 <+> quotes (text (TH.pprint nm))-                 <+> text "has no equations")-  | otherwise-  = do  { nm' <- vNameL nm-        ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls-        ; returnJustL $ Hs.ValD noExt $ mkFunBind nm' cls' }--cvtDec (TH.SigD nm typ)-  = do  { nm' <- vNameL nm-        ; ty' <- cvtType typ-        ; returnJustL $ Hs.SigD noExt-                                    (TypeSig noExt [nm'] (mkLHsSigWcType ty')) }--cvtDec (TH.InfixD fx nm)-  -- Fixity signatures are allowed for variables, constructors, and types-  -- the renamer automatically looks for types during renaming, even when-  -- the RdrName says it's a variable or a constructor. So, just assume-  -- it's a variable or constructor and proceed.-  = do { nm' <- vcNameL nm-       ; returnJustL (Hs.SigD noExt (FixSig noExt-                                      (FixitySig noExt [nm'] (cvtFixity fx)))) }--cvtDec (PragmaD prag)-  = cvtPragmaD prag--cvtDec (TySynD tc tvs rhs)-  = do  { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs-        ; rhs' <- cvtType rhs-        ; returnJustL $ TyClD noExt $-          SynDecl { tcdSExt = noExt, tcdLName = tc', tcdTyVars = tvs'-                  , tcdFixity = Prefix-                  , tcdRhs = rhs' } }--cvtDec (DataD ctxt tc tvs ksig constrs derivs)-  = do  { let isGadtCon (GadtC    _ _ _) = True-              isGadtCon (RecGadtC _ _ _) = True-              isGadtCon (ForallC  _ _ c) = isGadtCon c-              isGadtCon _                = False-              isGadtDecl  = all isGadtCon constrs-              isH98Decl   = all (not . isGadtCon) constrs-        ; unless (isGadtDecl || isH98Decl)-                 (failWith (text "Cannot mix GADT constructors with Haskell 98"-                        <+> text "constructors"))-        ; unless (isNothing ksig || isGadtDecl)-                 (failWith (text "Kind signatures are only allowed on GADTs"))-        ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs-        ; ksig' <- cvtKind `traverse` ksig-        ; cons' <- mapM cvtConstr constrs-        ; derivs' <- cvtDerivs derivs-        ; let defn = HsDataDefn { dd_ext = noExt-                                , dd_ND = DataType, dd_cType = Nothing-                                , dd_ctxt = ctxt'-                                , dd_kindSig = ksig'-                                , dd_cons = cons', dd_derivs = derivs' }-        ; returnJustL $ TyClD noExt (DataDecl-                                        { tcdDExt = noExt-                                        , tcdLName = tc', tcdTyVars = tvs'-                                        , tcdFixity = Prefix-                                        , tcdDataDefn = defn }) }--cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)-  = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs-        ; ksig' <- cvtKind `traverse` ksig-        ; con' <- cvtConstr constr-        ; derivs' <- cvtDerivs derivs-        ; let defn = HsDataDefn { dd_ext = noExt-                                , dd_ND = NewType, dd_cType = Nothing-                                , dd_ctxt = ctxt'-                                , dd_kindSig = ksig'-                                , dd_cons = [con']-                                , dd_derivs = derivs' }-        ; returnJustL $ TyClD noExt (DataDecl-                                    { tcdDExt = noExt-                                    , tcdLName = tc', tcdTyVars = tvs'-                                    , tcdFixity = Prefix-                                    , tcdDataDefn = defn }) }--cvtDec (ClassD ctxt cl tvs fds decs)-  = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs-        ; fds'  <- mapM cvt_fundep fds-        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (text "a class declaration") decs-        ; unless (null adts')-            (failWith $ (text "Default data instance declarations"-                     <+> text "are not allowed:")-                   $$ (Outputable.ppr adts'))-        ; at_defs <- mapM cvt_at_def ats'-        ; returnJustL $ TyClD noExt $-          ClassDecl { tcdCExt = noExt-                    , tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'-                    , tcdFixity = Prefix-                    , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'-                    , tcdMeths = binds'-                    , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = [] }-                              -- no docs in TH ^^-        }-  where-    cvt_at_def :: LTyFamInstDecl GhcPs -> CvtM (LTyFamDefltEqn GhcPs)-    -- Very similar to what happens in RdrHsSyn.mkClassDecl-    cvt_at_def decl = case RdrHsSyn.mkATDefault decl of-                        Right (def, _) -> return def-                        Left (_, msg) -> failWith msg--cvtDec (InstanceD o ctxt ty decs)-  = do  { let doc = text "an instance declaration"-        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs-        ; unless (null fams') (failWith (mkBadDecMsg doc fams'))-        ; ctxt' <- cvtContext ctxt-        ; (dL->L loc ty') <- cvtType ty-        ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty'-        ; returnJustL $ InstD noExt $ ClsInstD noExt $-          ClsInstDecl { cid_ext = noExt, cid_poly_ty = mkLHsSigType inst_ty'-                      , cid_binds = binds'-                      , cid_sigs = Hs.mkClassOpSigs sigs'-                      , cid_tyfam_insts = ats', cid_datafam_insts = adts'-                      , cid_overlap_mode = fmap (cL loc . overlap) o } }-  where-  overlap pragma =-    case pragma of-      TH.Overlaps      -> Hs.Overlaps     (SourceText "OVERLAPS")-      TH.Overlappable  -> Hs.Overlappable (SourceText "OVERLAPPABLE")-      TH.Overlapping   -> Hs.Overlapping  (SourceText "OVERLAPPING")-      TH.Incoherent    -> Hs.Incoherent   (SourceText "INCOHERENT")-----cvtDec (ForeignD ford)-  = do { ford' <- cvtForD ford-       ; returnJustL $ ForD noExt ford' }--cvtDec (DataFamilyD tc tvs kind)-  = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs-       ; result <- cvtMaybeKindToFamilyResultSig kind-       ; returnJustL $ TyClD noExt $ FamDecl noExt $-         FamilyDecl noExt DataFamily tc' tvs' Prefix result Nothing }--cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)-  = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys-       ; ksig' <- cvtKind `traverse` ksig-       ; cons' <- mapM cvtConstr constrs-       ; derivs' <- cvtDerivs derivs-       ; let defn = HsDataDefn { dd_ext = noExt-                               , dd_ND = DataType, dd_cType = Nothing-                               , dd_ctxt = ctxt'-                               , dd_kindSig = ksig'-                               , dd_cons = cons', dd_derivs = derivs' }--       ; returnJustL $ InstD noExt $ DataFamInstD-           { dfid_ext = noExt-           , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $-                           FamEqn { feqn_ext = noExt-                                  , feqn_tycon = tc'-                                  , feqn_bndrs = bndrs'-                                  , feqn_pats = typats'-                                  , feqn_rhs = defn-                                  , feqn_fixity = Prefix } }}}--cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs)-  = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys-       ; ksig' <- cvtKind `traverse` ksig-       ; con' <- cvtConstr constr-       ; derivs' <- cvtDerivs derivs-       ; let defn = HsDataDefn { dd_ext = noExt-                               , dd_ND = NewType, dd_cType = Nothing-                               , dd_ctxt = ctxt'-                               , dd_kindSig = ksig'-                               , dd_cons = [con'], dd_derivs = derivs' }-       ; returnJustL $ InstD noExt $ DataFamInstD-           { dfid_ext = noExt-           , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $-                           FamEqn { feqn_ext = noExt-                                  , feqn_tycon = tc'-                                  , feqn_bndrs = bndrs'-                                  , feqn_pats = typats'-                                  , feqn_rhs = defn-                                  , feqn_fixity = Prefix } }}}--cvtDec (TySynInstD eqn)-  = do  { (dL->L _ eqn') <- cvtTySynEqn eqn-        ; returnJustL $ InstD noExt $ TyFamInstD-            { tfid_ext = noExt-            , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }--cvtDec (OpenTypeFamilyD head)-  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head-       ; returnJustL $ TyClD noExt $ FamDecl noExt $-         FamilyDecl noExt OpenTypeFamily tc' tyvars' Prefix result' injectivity'-       }--cvtDec (ClosedTypeFamilyD head eqns)-  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head-       ; eqns' <- mapM cvtTySynEqn eqns-       ; returnJustL $ TyClD noExt $ FamDecl noExt $-         FamilyDecl noExt (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix-                           result' injectivity' }--cvtDec (TH.RoleAnnotD tc roles)-  = do { tc' <- tconNameL tc-       ; let roles' = map (noLoc . cvtRole) roles-       ; returnJustL $ Hs.RoleAnnotD noExt (RoleAnnotDecl noExt tc' roles') }--cvtDec (TH.StandaloneDerivD ds cxt ty)-  = do { cxt' <- cvtContext cxt-       ; ds'  <- traverse cvtDerivStrategy ds-       ; (dL->L loc ty') <- cvtType ty-       ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty'-       ; returnJustL $ DerivD noExt $-         DerivDecl { deriv_ext =noExt-                   , deriv_strategy = ds'-                   , deriv_type = mkLHsSigWcType inst_ty'-                   , deriv_overlap_mode = Nothing } }--cvtDec (TH.DefaultSigD nm typ)-  = do { nm' <- vNameL nm-       ; ty' <- cvtType typ-       ; returnJustL $ Hs.SigD noExt-                     $ ClassOpSig noExt True [nm'] (mkLHsSigType ty')}--cvtDec (TH.PatSynD nm args dir pat)-  = do { nm'   <- cNameL nm-       ; args' <- cvtArgs args-       ; dir'  <- cvtDir nm' dir-       ; pat'  <- cvtPat pat-       ; returnJustL $ Hs.ValD noExt $ PatSynBind noExt $-           PSB noExt nm' args' pat' dir' }-  where-    cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args-    cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2-    cvtArgs (TH.RecordPatSyn sels)-      = do { sels' <- mapM vNameL sels-           ; vars' <- mapM (vNameL . mkNameS . nameBase) sels-           ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' }--    cvtDir _ Unidir          = return Unidirectional-    cvtDir _ ImplBidir       = return ImplicitBidirectional-    cvtDir n (ExplBidir cls) =-      do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls-         ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }--cvtDec (TH.PatSynSigD nm ty)-  = do { nm' <- cNameL nm-       ; ty' <- cvtPatSynSigTy ty-       ; returnJustL $ Hs.SigD noExt $ PatSynSig noExt [nm'] (mkLHsSigType ty')}---- Implicit parameter bindings are handled in cvtLocalDecs and--- cvtImplicitParamBind. They are not allowed in any other scope, so--- reaching this case indicates an error.-cvtDec (TH.ImplicitParamBindD _ _)-  = failWith (text "Implicit parameter binding only allowed in let or where")-------------------cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)-cvtTySynEqn (TySynEqn mb_bndrs lhs rhs)-  = do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs-       ; (head_ty, args) <- split_ty_app lhs-       ; case head_ty of-           ConT nm -> do { nm' <- tconNameL nm-                         ; rhs' <- cvtType rhs-                         ; let args' = map wrap_tyarg args-                         ; returnL $ mkHsImplicitBndrs-                            $ FamEqn { feqn_ext    = noExt-                                     , feqn_tycon  = nm'-                                     , feqn_bndrs  = mb_bndrs'-                                     , feqn_pats   = args'-                                     , feqn_fixity = Prefix-                                     , feqn_rhs    = rhs' } }-           InfixT t1 nm t2 -> do { nm' <- tconNameL nm-                                 ; args' <- mapM cvtType [t1,t2]-                                 ; rhs' <- cvtType rhs-                                 ; returnL $ mkHsImplicitBndrs-                                      $ FamEqn { feqn_ext    = noExt-                                               , feqn_tycon  = nm'-                                               , feqn_bndrs  = mb_bndrs'-                                               , feqn_pats   =-                                                (map HsValArg args') ++ args-                                               , feqn_fixity = Hs.Infix-                                               , feqn_rhs    = rhs' } }-           _ -> failWith $ text "Invalid type family instance LHS:"-                          <+> text (show lhs)-        }-------------------cvt_ci_decs :: MsgDoc -> [TH.Dec]-            -> CvtM (LHsBinds GhcPs,-                     [LSig GhcPs],-                     [LFamilyDecl GhcPs],-                     [LTyFamInstDecl GhcPs],-                     [LDataFamInstDecl GhcPs])--- Convert the declarations inside a class or instance decl--- ie signatures, bindings, and associated types-cvt_ci_decs doc decs-  = do  { decs' <- cvtDecs decs-        ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs'-        ; let (adts', no_ats')       = partitionWith is_datafam_inst bind_sig_decs'-        ; let (sigs', prob_binds')   = partitionWith is_sig no_ats'-        ; let (binds', prob_fams')   = partitionWith is_bind prob_binds'-        ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'-        ; unless (null bads) (failWith (mkBadDecMsg doc bads))-          --We use FromSource as the origin of the bind-          -- because the TH declaration is user-written-        ; return (listToBag binds', sigs', fams', ats', adts') }-------------------cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]-             -> CvtM ( LHsContext GhcPs-                     , Located RdrName-                     , LHsQTyVars GhcPs)-cvt_tycl_hdr cxt tc tvs-  = do { cxt' <- cvtContext cxt-       ; tc'  <- tconNameL tc-       ; tvs' <- cvtTvs tvs-       ; return (cxt', tc', tvs')-       }--cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr] -> TH.Type-               -> CvtM ( LHsContext GhcPs-                       , Located RdrName-                       , Maybe [LHsTyVarBndr GhcPs]-                       , HsTyPats GhcPs)-cvt_datainst_hdr cxt bndrs tys-  = do { cxt' <- cvtContext cxt-       ; bndrs' <- traverse (mapM cvt_tv) bndrs-       ; (head_ty, args) <- split_ty_app tys-       ; case head_ty of-          ConT nm -> do { nm' <- tconNameL nm-                        ; let args' = map wrap_tyarg args-                        ; return (cxt', nm', bndrs', args') }-          InfixT t1 nm t2 -> do { nm' <- tconNameL nm-                                ; args' <- mapM cvtType [t1,t2]-                                ; return (cxt', nm', bndrs',-                                         ((map HsValArg args') ++ args)) }-          _ -> failWith $ text "Invalid type instance header:"-                          <+> text (show tys) }-------------------cvt_tyfam_head :: TypeFamilyHead-               -> CvtM ( Located RdrName-                       , LHsQTyVars GhcPs-                       , Hs.LFamilyResultSig GhcPs-                       , Maybe (Hs.LInjectivityAnn GhcPs))--cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity)-  = do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars-       ; result' <- cvtFamilyResultSig result-       ; injectivity' <- traverse cvtInjectivityAnnotation injectivity-       ; return (tc', tyvars', result', injectivity') }------------------------------------------------------------------------              Partitioning declarations----------------------------------------------------------------------is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)-is_fam_decl (dL->L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (cL loc d)-is_fam_decl decl = Right decl--is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)-is_tyfam_inst (dL->L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))-  = Left (cL loc d)-is_tyfam_inst decl-  = Right decl--is_datafam_inst :: LHsDecl GhcPs-                -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)-is_datafam_inst (dL->L loc (Hs.InstD  _ (DataFamInstD { dfid_inst = d })))-  = Left (cL loc d)-is_datafam_inst decl-  = Right decl--is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)-is_sig (dL->L loc (Hs.SigD _ sig)) = Left (cL loc sig)-is_sig decl                        = Right decl--is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)-is_bind (dL->L loc (Hs.ValD _ bind)) = Left (cL loc bind)-is_bind decl                         = Right decl--is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec-is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e)-is_ip_bind decl             = Right decl--mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc-mkBadDecMsg doc bads-  = sep [ text "Illegal declaration(s) in" <+> doc <> colon-        , nest 2 (vcat (map Outputable.ppr bads)) ]--------------------------------------------------------      Data types------------------------------------------------------cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)--cvtConstr (NormalC c strtys)-  = do  { c'   <- cNameL c-        ; tys' <- mapM cvt_arg strtys-        ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon tys') }--cvtConstr (RecC c varstrtys)-  = do  { c'    <- cNameL c-        ; args' <- mapM cvt_id_arg varstrtys-        ; returnL $ mkConDeclH98 c' Nothing Nothing-                                   (RecCon (noLoc args')) }--cvtConstr (InfixC st1 c st2)-  = do  { c'   <- cNameL c-        ; st1' <- cvt_arg st1-        ; st2' <- cvt_arg st2-        ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon st1' st2') }--cvtConstr (ForallC tvs ctxt con)-  = do  { tvs'      <- cvtTvs tvs-        ; ctxt'     <- cvtContext ctxt-        ; (dL->L _ con')  <- cvtConstr con-        ; returnL $ add_forall tvs' ctxt' con' }-  where-    add_cxt lcxt         Nothing           = Just lcxt-    add_cxt (dL->L loc cxt1) (Just (dL->L _ cxt2))-      = Just (cL loc (cxt1 ++ cxt2))--    add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })-      = con { con_forall = noLoc $ not (null all_tvs)-            , con_qvars  = mkHsQTvs all_tvs-            , con_mb_cxt = add_cxt cxt' cxt }-      where-        all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars--    add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt })-      = con { con_forall = noLoc $ not (null all_tvs)-            , con_ex_tvs = all_tvs-            , con_mb_cxt = add_cxt cxt' cxt }-      where-        all_tvs = hsQTvExplicit tvs' ++ ex_tvs--    add_forall _ _ (XConDecl _) = panic "cvtConstr"--cvtConstr (GadtC c strtys ty)-  = do  { c'      <- mapM cNameL c-        ; args    <- mapM cvt_arg strtys-        ; (dL->L _ ty') <- cvtType ty-        ; c_ty    <- mk_arr_apps args ty'-        ; returnL $ fst $ mkGadtDecl c' c_ty}--cvtConstr (RecGadtC c varstrtys ty)-  = do  { c'       <- mapM cNameL c-        ; ty'      <- cvtType ty-        ; rec_flds <- mapM cvt_id_arg varstrtys-        ; let rec_ty = noLoc (HsFunTy noExt-                                           (noLoc $ HsRecTy noExt rec_flds) ty')-        ; returnL $ fst $ mkGadtDecl c' rec_ty }--cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness-cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack-cvtSrcUnpackedness SourceNoUnpack       = SrcNoUnpack-cvtSrcUnpackedness SourceUnpack         = SrcUnpack--cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness-cvtSrcStrictness NoSourceStrictness = NoSrcStrict-cvtSrcStrictness SourceLazy         = SrcLazy-cvtSrcStrictness SourceStrict       = SrcStrict--cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs)-cvt_arg (Bang su ss, ty)-  = do { ty'' <- cvtType ty-       ; let ty' = parenthesizeHsType appPrec ty''-             su' = cvtSrcUnpackedness su-             ss' = cvtSrcStrictness ss-       ; returnL $ HsBangTy noExt (HsSrcBang NoSourceText su' ss') ty' }--cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)-cvt_id_arg (i, str, ty)-  = do  { (dL->L li i') <- vNameL i-        ; ty' <- cvt_arg (str,ty)-        ; return $ noLoc (ConDeclField-                          { cd_fld_ext = noExt-                          , cd_fld_names-                              = [cL li $ FieldOcc noExt (cL li i')]-                          , cd_fld_type =  ty'-                          , cd_fld_doc = Nothing}) }--cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)-cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs-                  ; returnL cs' }--cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs)-cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs-                               ; ys' <- mapM tNameL ys-                               ; returnL (xs', ys') }------------------------------------------------      Foreign declarations---------------------------------------------cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)-cvtForD (ImportF callconv safety from nm ty)-  -- the prim and javascript calling conventions do not support headers-  -- and are inserted verbatim, analogous to mkImport in RdrHsSyn-  | callconv == TH.Prim || callconv == TH.JavaScript-  = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing-                    (CFunction (StaticTarget (SourceText from)-                                             (mkFastString from) Nothing-                                             True))-                    (noLoc $ quotedSourceText from))-  | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')-                                 (mkFastString (TH.nameBase nm))-                                 from (noLoc $ quotedSourceText from)-  = mk_imp impspec-  | otherwise-  = failWith $ text (show from) <+> text "is not a valid ccall impent"-  where-    mk_imp impspec-      = do { nm' <- vNameL nm-           ; ty' <- cvtType ty-           ; return (ForeignImport { fd_i_ext = noExt-                                   , fd_name = nm'-                                   , fd_sig_ty = mkLHsSigType ty'-                                   , fd_fi = impspec })-           }-    safety' = case safety of-                     Unsafe     -> PlayRisky-                     Safe       -> PlaySafe-                     Interruptible -> PlayInterruptible--cvtForD (ExportF callconv as nm ty)-  = do  { nm' <- vNameL nm-        ; ty' <- cvtType ty-        ; let e = CExport (noLoc (CExportStatic (SourceText as)-                                                (mkFastString as)-                                                (cvt_conv callconv)))-                                                (noLoc (SourceText as))-        ; return $ ForeignExport { fd_e_ext = noExt-                                 , fd_name = nm'-                                 , fd_sig_ty = mkLHsSigType ty'-                                 , fd_fe = e } }--cvt_conv :: TH.Callconv -> CCallConv-cvt_conv TH.CCall      = CCallConv-cvt_conv TH.StdCall    = StdCallConv-cvt_conv TH.CApi       = CApiConv-cvt_conv TH.Prim       = PrimCallConv-cvt_conv TH.JavaScript = JavaScriptCallConv-----------------------------------------------              Pragmas---------------------------------------------cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))-cvtPragmaD (InlineP nm inline rm phases)-  = do { nm' <- vNameL nm-       ; let dflt = dfltActivation inline-       ; let src TH.NoInline  = "{-# NOINLINE"-             src TH.Inline    = "{-# INLINE"-             src TH.Inlinable = "{-# INLINABLE"-       ; let ip   = InlinePragma { inl_src    = SourceText $ src inline-                                 , inl_inline = cvtInline inline-                                 , inl_rule   = cvtRuleMatch rm-                                 , inl_act    = cvtPhases phases dflt-                                 , inl_sat    = Nothing }-       ; returnJustL $ Hs.SigD noExt $ InlineSig noExt nm' ip }--cvtPragmaD (SpecialiseP nm ty inline phases)-  = do { nm' <- vNameL nm-       ; ty' <- cvtType ty-       ; let src TH.NoInline  = "{-# SPECIALISE NOINLINE"-             src TH.Inline    = "{-# SPECIALISE INLINE"-             src TH.Inlinable = "{-# SPECIALISE INLINE"-       ; let (inline', dflt,srcText) = case inline of-               Just inline1 -> (cvtInline inline1, dfltActivation inline1,-                                src inline1)-               Nothing      -> (NoUserInline,   AlwaysActive,-                                "{-# SPECIALISE")-       ; let ip = InlinePragma { inl_src    = SourceText srcText-                               , inl_inline = inline'-                               , inl_rule   = Hs.FunLike-                               , inl_act    = cvtPhases phases dflt-                               , inl_sat    = Nothing }-       ; returnJustL $ Hs.SigD noExt $ SpecSig noExt nm' [mkLHsSigType ty'] ip }--cvtPragmaD (SpecialiseInstP ty)-  = do { ty' <- cvtType ty-       ; returnJustL $ Hs.SigD noExt $-         SpecInstSig noExt (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }--cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)-  = do { let nm' = mkFastString nm-       ; let act = cvtPhases phases AlwaysActive-       ; ty_bndrs' <- traverse (mapM cvt_tv) ty_bndrs-       ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs-       ; lhs'   <- cvtl lhs-       ; rhs'   <- cvtl rhs-       ; returnJustL $ Hs.RuleD noExt-            $ HsRules { rds_ext = noExt-                      , rds_src = SourceText "{-# RULES"-                      , rds_rules = [noLoc $-                          HsRule { rd_ext  = noExt-                                 , rd_name = (noLoc (quotedSourceText nm,nm'))-                                 , rd_act  = act-                                 , rd_tyvs = ty_bndrs'-                                 , rd_tmvs = tm_bndrs'-                                 , rd_lhs  = lhs'-                                 , rd_rhs  = rhs' }] }--          }--cvtPragmaD (AnnP target exp)-  = do { exp' <- cvtl exp-       ; target' <- case target of-         ModuleAnnotation  -> return ModuleAnnProvenance-         TypeAnnotation n  -> do-           n' <- tconName n-           return (TypeAnnProvenance  (noLoc n'))-         ValueAnnotation n -> do-           n' <- vcName n-           return (ValueAnnProvenance (noLoc n'))-       ; returnJustL $ Hs.AnnD noExt-                     $ HsAnnotation noExt (SourceText "{-# ANN") target' exp'-       }--cvtPragmaD (LineP line file)-  = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))-       ; return Nothing-       }-cvtPragmaD (CompleteP cls mty)-  = do { cls' <- noLoc <$> mapM cNameL cls-       ; mty'  <- traverse tconNameL mty-       ; returnJustL $ Hs.SigD noExt-                   $ CompleteMatchSig noExt NoSourceText cls' mty' }--dfltActivation :: TH.Inline -> Activation-dfltActivation TH.NoInline = NeverActive-dfltActivation _           = AlwaysActive--cvtInline :: TH.Inline -> Hs.InlineSpec-cvtInline TH.NoInline  = Hs.NoInline-cvtInline TH.Inline    = Hs.Inline-cvtInline TH.Inlinable = Hs.Inlinable--cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo-cvtRuleMatch TH.ConLike = Hs.ConLike-cvtRuleMatch TH.FunLike = Hs.FunLike--cvtPhases :: TH.Phases -> Activation -> Activation-cvtPhases AllPhases       dflt = dflt-cvtPhases (FromPhase i)   _    = ActiveAfter NoSourceText i-cvtPhases (BeforePhase i) _    = ActiveBefore NoSourceText i--cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs)-cvtRuleBndr (RuleVar n)-  = do { n' <- vNameL n-       ; return $ noLoc $ Hs.RuleBndr noExt n' }-cvtRuleBndr (TypedRuleVar n ty)-  = do { n'  <- vNameL n-       ; ty' <- cvtType ty-       ; return $ noLoc $ Hs.RuleBndrSig noExt n' $ mkLHsSigWcType ty' }--------------------------------------------------------              Declarations------------------------------------------------------cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)-cvtLocalDecs doc ds-  = case partitionWith is_ip_bind ds of-      ([], []) -> return (EmptyLocalBinds noExt)-      ([], _) -> do-        ds' <- cvtDecs ds-        let (binds, prob_sigs) = partitionWith is_bind ds'-        let (sigs, bads) = partitionWith is_sig prob_sigs-        unless (null bads) (failWith (mkBadDecMsg doc bads))-        return (HsValBinds noExt (ValBinds noExt (listToBag binds) sigs))-      (ip_binds, []) -> do-        binds <- mapM (uncurry cvtImplicitParamBind) ip_binds-        return (HsIPBinds noExt (IPBinds noExt binds))-      ((_:_), (_:_)) ->-        failWith (text "Implicit parameters mixed with other bindings")--cvtClause :: HsMatchContext RdrName-          -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))-cvtClause ctxt (Clause ps body wheres)-  = do  { ps' <- cvtPats ps-        ; let pps = map (parenthesizePat appPrec) ps'-        ; g'  <- cvtGuard body-        ; ds' <- cvtLocalDecs (text "a where clause") wheres-        ; returnL $ Hs.Match noExt ctxt pps (GRHSs noExt g' (noLoc ds')) }--cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)-cvtImplicitParamBind n e = do-    n' <- wrapL (ipName n)-    e' <- cvtl e-    returnL (IPBind noExt (Left n') e')------------------------------------------------------------------------              Expressions----------------------------------------------------------------------cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)-cvtl e = wrapL (cvt e)-  where-    cvt (VarE s)        = do { s' <- vName s; return $ HsVar noExt (noLoc s') }-    cvt (ConE s)        = do { s' <- cName s; return $ HsVar noExt (noLoc s') }-    cvt (LitE l)-      | overloadedLit l = go cvtOverLit (HsOverLit noExt)-                             (hsOverLitNeedsParens appPrec)-      | otherwise       = go cvtLit (HsLit noExt)-                             (hsLitNeedsParens appPrec)-      where-        go :: (Lit -> CvtM (l GhcPs))-           -> (l GhcPs -> HsExpr GhcPs)-           -> (l GhcPs -> Bool)-           -> CvtM (HsExpr GhcPs)-        go cvt_lit mk_expr is_compound_lit = do-          l' <- cvt_lit l-          let e' = mk_expr l'-          return $ if is_compound_lit l' then HsPar noExt (noLoc e') else e'-    cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y-                                   ; return $ HsApp noExt (mkLHsPar x')-                                                          (mkLHsPar y')}-    cvt (AppE x y)            = do { x' <- cvtl x; y' <- cvtl y-                                   ; return $ HsApp noExt (mkLHsPar x')-                                                          (mkLHsPar y')}-    cvt (AppTypeE e t) = do { e' <- cvtl e-                            ; t' <- cvtType t-                            ; let tp = parenthesizeHsType appPrec t'-                            ; return $ HsAppType noExt e'-                                     $ mkHsWildCardBndrs tp }-    cvt (LamE [] e)    = cvt e -- Degenerate case. We convert the body as its-                               -- own expression to avoid pretty-printing-                               -- oddities that can result from zero-argument-                               -- lambda expressions. See #13856.-    cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e-                            ; let pats = map (parenthesizePat appPrec) ps'-                            ; return $ HsLam noExt (mkMatchGroup FromSource-                                             [mkSimpleMatch LambdaExpr-                                             pats e'])}-    cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch CaseAlt) ms-                            ; return $ HsLamCase noExt-                                                   (mkMatchGroup FromSource ms')-                            }-    cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar noExt e' }-                                 -- Note [Dropping constructors]-                                 -- Singleton tuples treated like nothing (just parens)-    cvt (TupE es)      = do { es' <- mapM cvtl es-                            ; return $ ExplicitTuple noExt-                                             (map (noLoc . (Present noExt)) es')-                                                                         Boxed }-    cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es-                                   ; return $ ExplicitTuple noExt-                                           (map (noLoc . (Present noExt)) es')-                                                                       Unboxed }-    cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e-                                       ; unboxedSumChecks alt arity-                                       ; return $ ExplicitSum noExt-                                                                   alt arity e'}-    cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;-                            ; return $ HsIf noExt (Just noSyntaxExpr) x' y' z' }-    cvt (MultiIfE alts)-      | null alts      = failWith (text "Multi-way if-expression with no alternatives")-      | otherwise      = do { alts' <- mapM cvtpair alts-                            ; return $ HsMultiIf noExt alts' }-    cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (text "a let expression") ds-                            ; e' <- cvtl e; return $ HsLet noExt (noLoc ds') e'}-    cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms-                            ; return $ HsCase noExt e'-                                                 (mkMatchGroup FromSource ms') }-    cvt (DoE ss)       = cvtHsDo DoExpr ss-    cvt (MDoE ss)      = cvtHsDo MDoExpr ss-    cvt (CompE ss)     = cvtHsDo ListComp ss-    cvt (ArithSeqE dd) = do { dd' <- cvtDD dd-                            ; return $ ArithSeq noExt Nothing dd' }-    cvt (ListE xs)-      | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s)-                                          ; return (HsLit noExt l') }-             -- Note [Converting strings]-      | otherwise       = do { xs' <- mapM cvtl xs-                             ; return $ ExplicitList noExt Nothing xs'-                             }--    -- Infix expressions-    cvt (InfixE (Just x) s (Just y)) =-      do { x' <- cvtl x-         ; s' <- cvtl s-         ; y' <- cvtl y-         ; let px = parenthesizeHsExpr opPrec x'-               py = parenthesizeHsExpr opPrec y'-         ; wrapParL (HsPar noExt)-           $ OpApp noExt px s' py }-           -- Parenthesise both arguments and result,-           -- to ensure this operator application does-           -- does not get re-associated-           -- See Note [Operator association]-    cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y-                                          ; wrapParL (HsPar noExt) $-                                                          SectionR noExt s' y' }-                                            -- See Note [Sections in HsSyn] in HsExpr-    cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s-                                          ; wrapParL (HsPar noExt) $-                                                          SectionL noExt x' s' }--    cvt (InfixE Nothing  s Nothing ) = do { s' <- cvtl s-                                          ; return $ HsPar noExt s' }-                                       -- Can I indicate this is an infix thing?-                                       -- Note [Dropping constructors]--    cvt (UInfixE x s y)  = do { x' <- cvtl x-                              ; let x'' = case unLoc x' of-                                            OpApp {} -> x'-                                            _ -> mkLHsPar x'-                              ; cvtOpApp x'' s y } --  Note [Converting UInfix]--    cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar noExt e' }-    cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t-                              ; let pe = parenthesizeHsExpr sigPrec e'-                              ; return $ ExprWithTySig noExt pe (mkLHsSigWcType t') }-    cvt (RecConE c flds) = do { c' <- cNameL c-                              ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds-                              ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }-    cvt (RecUpdE e flds) = do { e' <- cvtl e-                              ; flds'-                                  <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))-                                           flds-                              ; return $ mkRdrRecordUpd e' flds' }-    cvt (StaticE e)      = fmap (HsStatic noExt) $ cvtl e-    cvt (UnboundVarE s)  = do -- Use of 'vcName' here instead of 'vName' is-                              -- important, because UnboundVarE may contain-                              -- constructor names - see #14627.-                              { s' <- vcName s-                              ; return $ HsVar noExt (noLoc s') }-    cvt (LabelE s)       = do { return $ HsOverLabel noExt Nothing (fsLit s) }-    cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExt n' }--{- Note [Dropping constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we drop constructors from the input (for instance, when we encounter @TupE [e]@)-we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@-could meet @UInfix@ constructors containing the @TupE [e]@. For example:--  UInfixE x * (TupE [UInfixE y + z])--If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet-and the above expression would be reassociated to--  OpApp (OpApp x * y) + z--which we don't want.--}--cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp)-       -> CvtM (LHsRecField' t (LHsExpr GhcPs))-cvtFld f (v,e)-  = do  { v' <- vNameL v; e' <- cvtl e-        ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v'-                                     , hsRecFieldArg = e'-                                     , hsRecPun      = False}) }--cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs)-cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }-cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }-cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }-cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }--{- Note [Operator assocation]-We must be quite careful about adding parens:-  * Infix (UInfix ...) op arg      Needs parens round the first arg-  * Infix (Infix ...) op arg       Needs parens round the first arg-  * UInfix (UInfix ...) op arg     No parens for first arg-  * UInfix (Infix ...) op arg      Needs parens round first arg---Note [Converting UInfix]-~~~~~~~~~~~~~~~~~~~~~~~~-When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust-the trees to reflect the fixities of the underlying operators:--  UInfixE x * (UInfixE y + z) ---> (x * y) + z--This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and-@mkHsOpTyRn@ in RnTypes), which expects that the input will be completely-right-biased for types and left-biased for everything else. So we left-bias the-trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@.--Sample input:--  UInfixE-   (UInfixE x op1 y)-   op2-   (UInfixE z op3 w)--Sample output:--  OpApp-    (OpApp-      (OpApp x op1 y)-      op2-      z)-    op3-    w--The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this-biasing.--}--{- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.-The produced tree of infix expressions will be left-biased, provided @x@ is.--We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis-is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that-this holds for both branches (of @cvtOpApp@), provided we assume it holds for-the recursive calls to @cvtOpApp@.--When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased-since we have already run @cvtl@ on it.--}-cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs)-cvtOpApp x op1 (UInfixE y op2 z)-  = do { l <- wrapL $ cvtOpApp x op1 y-       ; cvtOpApp l op2 z }-cvtOpApp x op y-  = do { op' <- cvtl op-       ; y' <- cvtl y-       ; return (OpApp noExt x op' y') }------------------------------------------      Do notation and statements----------------------------------------cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr GhcPs)-cvtHsDo do_or_lc stmts-  | null stmts = failWith (text "Empty stmt list in do-block")-  | otherwise-  = do  { stmts' <- cvtStmts stmts-        ; let Just (stmts'', last') = snocView stmts'--        ; last'' <- case last' of-                    (dL->L loc (BodyStmt _ body _ _))-                      -> return (cL loc (mkLastStmt body))-                    _ -> failWith (bad_last last')--        ; return $ HsDo noExt do_or_lc (noLoc (stmts'' ++ [last''])) }-  where-    bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon-                         , nest 2 $ Outputable.ppr stmt-                         , text "(It should be an expression.)" ]--cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)]-cvtStmts = mapM cvtStmt--cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs))-cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkBodyStmt e' }-cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }-cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (text "a let binding") ds-                            ; returnL $ LetStmt noExt (noLoc ds') }-cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss-                            ; returnL $ ParStmt noExt dss' noExpr noSyntaxExpr }-  where-    cvt_one ds = do { ds' <- cvtStmts ds-                    ; return (ParStmtBlock noExt ds' undefined noSyntaxExpr) }-cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnL (mkRecStmt ss') }--cvtMatch :: HsMatchContext RdrName-         -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))-cvtMatch ctxt (TH.Match p body decs)-  = do  { p' <- cvtPat p-        ; let lp = case p' of-                     (dL->L loc SigPat{}) -> cL loc (ParPat NoExt p') -- #14875-                     _                    -> p'-        ; g' <- cvtGuard body-        ; decs' <- cvtLocalDecs (text "a where clause") decs-        ; returnL $ Hs.Match noExt ctxt [lp] (GRHSs noExt g' (noLoc decs')) }--cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]-cvtGuard (GuardedB pairs) = mapM cvtpair pairs-cvtGuard (NormalB e)      = do { e' <- cvtl e-                               ; g' <- returnL $ GRHS noExt [] e'; return [g'] }--cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))-cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs-                              ; g' <- returnL $ mkBodyStmt ge'-                              ; returnL $ GRHS noExt [g'] rhs' }-cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs-                              ; returnL $ GRHS noExt gs' rhs' }--cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs)-cvtOverLit (IntegerL i)-  = do { force i; return $ mkHsIntegral   (mkIntegralLit i) }-cvtOverLit (RationalL r)-  = do { force r; return $ mkHsFractional (mkFractionalLit r) }-cvtOverLit (StringL s)-  = do { let { s' = mkFastString s }-       ; force s'-       ; return $ mkHsIsString (quotedSourceText s) s'-       }-cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"--- An Integer is like an (overloaded) '3' in a Haskell source program--- Similarly 3.5 for fractionals--{- Note [Converting strings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to-a string literal for "xy".  Of course, we might hope to get-(LitE (StringL "xy")), but not always, and allCharLs fails quickly-if it isn't a literal string--}--allCharLs :: [TH.Exp] -> Maybe String--- Note [Converting strings]--- NB: only fire up this setup for a non-empty list, else---     there's a danger of returning "" for [] :: [Int]!-allCharLs xs-  = case xs of-      LitE (CharL c) : ys -> go [c] ys-      _                   -> Nothing-  where-    go cs []                    = Just (reverse cs)-    go cs (LitE (CharL c) : ys) = go (c:cs) ys-    go _  _                     = Nothing--cvtLit :: Lit -> CvtM (HsLit GhcPs)-cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim NoSourceText i }-cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim NoSourceText w }-cvtLit (FloatPrimL f)-  = do { force f; return $ HsFloatPrim noExt (mkFractionalLit f) }-cvtLit (DoublePrimL f)-  = do { force f; return $ HsDoublePrim noExt (mkFractionalLit f) }-cvtLit (CharL c)       = do { force c; return $ HsChar NoSourceText c }-cvtLit (CharPrimL c)   = do { force c; return $ HsCharPrim NoSourceText c }-cvtLit (StringL s)     = do { let { s' = mkFastString s }-                            ; force s'-                            ; return $ HsString (quotedSourceText s) s' }-cvtLit (StringPrimL s) = do { let { s' = BS.pack s }-                            ; force s'-                            ; return $ HsStringPrim NoSourceText s' }-cvtLit _ = panic "Convert.cvtLit: Unexpected literal"-        -- cvtLit should not be called on IntegerL, RationalL-        -- That precondition is established right here in-        -- Convert.hs, hence panic--quotedSourceText :: String -> SourceText-quotedSourceText s = SourceText $ "\"" ++ s ++ "\""--cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs]-cvtPats pats = mapM cvtPat pats--cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs)-cvtPat pat = wrapL (cvtp pat)--cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs)-cvtp (TH.LitP l)-  | overloadedLit l    = do { l' <- cvtOverLit l-                            ; return (mkNPat (noLoc l') Nothing) }-                                  -- Not right for negative patterns;-                                  -- need to think about that!-  | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat noExt l' }-cvtp (TH.VarP s)       = do { s' <- vName s-                            ; return $ Hs.VarPat noExt (noLoc s') }-cvtp (TupP [p])        = do { p' <- cvtPat p; return $ ParPat noExt p' }-                                         -- Note [Dropping constructors]-cvtp (TupP ps)         = do { ps' <- cvtPats ps-                            ; return $ TuplePat noExt ps' Boxed }-cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps-                            ; return $ TuplePat noExt ps' Unboxed }-cvtp (UnboxedSumP p alt arity)-                       = do { p' <- cvtPat p-                            ; unboxedSumChecks alt arity-                            ; return $ SumPat noExt p' alt arity }-cvtp (ConP s ps)       = do { s' <- cNameL s; ps' <- cvtPats ps-                            ; let pps = map (parenthesizePat appPrec) ps'-                            ; return $ ConPatIn s' (PrefixCon pps) }-cvtp (InfixP p1 s p2)  = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2-                            ; wrapParL (ParPat noExt) $-                              ConPatIn s' $-                              InfixCon (parenthesizePat opPrec p1')-                                       (parenthesizePat opPrec p2') }-                            -- See Note [Operator association]-cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]-cvtp (ParensP p)       = do { p' <- cvtPat p;-                            ; case unLoc p' of  -- may be wrapped ConPatIn-                                ParPat {} -> return $ unLoc p'-                                _         -> return $ ParPat noExt p' }-cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat noExt p' }-cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat noExt p' }-cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p-                            ; return $ AsPat noExt s' p' }-cvtp TH.WildP          = return $ WildPat noExt-cvtp (RecP c fs)       = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs-                            ; return $ ConPatIn c'-                                     $ Hs.RecCon (HsRecFields fs' Nothing) }-cvtp (ListP ps)        = do { ps' <- cvtPats ps-                            ; return-                                   $ ListPat noExt ps'}-cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t-                            ; return $ SigPat noExt p' (mkLHsSigWcType t') }-cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p-                            ; return $ ViewPat noExt e' p'}--cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))-cvtPatFld (s,p)-  = do  { (dL->L ls s') <- vNameL s-        ; p' <- cvtPat p-        ; return (noLoc $ HsRecField { hsRecFieldLbl-                                         = cL ls $ mkFieldOcc (cL ls s')-                                     , hsRecFieldArg = p'-                                     , hsRecPun      = False}) }--{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.-The produced tree of infix patterns will be left-biased, provided @x@ is.--See the @cvtOpApp@ documentation for how this function works.--}-cvtOpAppP :: Hs.LPat GhcPs -> TH.Name -> TH.Pat -> CvtM (Hs.Pat GhcPs)-cvtOpAppP x op1 (UInfixP y op2 z)-  = do { l <- wrapL $ cvtOpAppP x op1 y-       ; cvtOpAppP l op2 z }-cvtOpAppP x op y-  = do { op' <- cNameL op-       ; y' <- cvtPat y-       ; return (ConPatIn op' (InfixCon x y')) }----------------------------------------------------------------      Types and type variables--cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars GhcPs)-cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }--cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs)-cvt_tv (TH.PlainTV nm)-  = do { nm' <- tNameL nm-       ; returnL $ UserTyVar noExt nm' }-cvt_tv (TH.KindedTV nm ki)-  = do { nm' <- tNameL nm-       ; ki' <- cvtKind ki-       ; returnL $ KindedTyVar noExt nm' ki' }--cvtRole :: TH.Role -> Maybe Coercion.Role-cvtRole TH.NominalR          = Just Coercion.Nominal-cvtRole TH.RepresentationalR = Just Coercion.Representational-cvtRole TH.PhantomR          = Just Coercion.Phantom-cvtRole TH.InferR            = Nothing--cvtContext :: TH.Cxt -> CvtM (LHsContext GhcPs)-cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }--cvtPred :: TH.Pred -> CvtM (LHsType GhcPs)-cvtPred = cvtType--cvtDerivClause :: TH.DerivClause-               -> CvtM (LHsDerivingClause GhcPs)-cvtDerivClause (TH.DerivClause ds ctxt)-  = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext ctxt-       ; ds'   <- traverse cvtDerivStrategy ds-       ; returnL $ HsDerivingClause noExt ds' ctxt' }--cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)-cvtDerivStrategy TH.StockStrategy    = returnL Hs.StockStrategy-cvtDerivStrategy TH.AnyclassStrategy = returnL Hs.AnyclassStrategy-cvtDerivStrategy TH.NewtypeStrategy  = returnL Hs.NewtypeStrategy-cvtDerivStrategy (TH.ViaStrategy ty) = do-  ty' <- cvtType ty-  returnL $ Hs.ViaStrategy (mkLHsSigType ty')--cvtType :: TH.Type -> CvtM (LHsType GhcPs)-cvtType = cvtTypeKind "type"--cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs)-cvtTypeKind ty_str ty-  = do { (head_ty, tys') <- split_ty_app ty-       ; let m_normals = mapM extract_normal tys'-                                where extract_normal (HsValArg ty) = Just ty-                                      extract_normal _ = Nothing--       ; case head_ty of-           TupleT n-            | Just normals <- m_normals-            , normals `lengthIs` n         -- Saturated-               -> if n==1 then return (head normals) -- Singleton tuples treated-                                                     -- like nothing (ie just parens)-                          else returnL (HsTupleTy noExt-                                        HsBoxedOrConstraintTuple normals)-            | n == 1-               -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))-            | otherwise-            -> mk_apps-               (HsTyVar noExt NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n))))-               tys'-           UnboxedTupleT n-             | Just normals <- m_normals-             , normals `lengthIs` n               -- Saturated-             -> returnL (HsTupleTy noExt HsUnboxedTuple normals)-             | otherwise-             -> mk_apps-                (HsTyVar noExt NotPromoted (noLoc (getRdrName (tupleTyCon Unboxed n))))-                tys'-           UnboxedSumT n-             | n < 2-            -> failWith $-                   vcat [ text "Illegal sum arity:" <+> text (show n)-                        , nest 2 $-                            text "Sums must have an arity of at least 2" ]-             | Just normals <- m_normals-             , normals `lengthIs` n -- Saturated-             -> returnL (HsSumTy noExt normals)-             | otherwise-             -> mk_apps-                (HsTyVar noExt NotPromoted (noLoc (getRdrName (sumTyCon n))))-                tys'-           ArrowT-             | Just normals <- m_normals-             , [x',y'] <- normals -> do-                 x'' <- case unLoc x' of-                          HsFunTy{}    -> returnL (HsParTy noExt x')-                          HsForAllTy{} -> returnL (HsParTy noExt x') -- #14646-                          HsQualTy{}   -> returnL (HsParTy noExt x') -- #15324-                          _            -> return $-                                          parenthesizeHsType sigPrec x'-                 let y'' = parenthesizeHsType sigPrec y'-                 returnL (HsFunTy noExt x'' y'')-             | otherwise-             -> mk_apps-                (HsTyVar noExt NotPromoted (noLoc (getRdrName funTyCon)))-                tys'-           ListT-             | Just normals <- m_normals-             , [x'] <- normals -> do-                returnL (HsListTy noExt x')-             | otherwise-             -> mk_apps-                (HsTyVar noExt NotPromoted (noLoc (getRdrName listTyCon)))-                tys'--           VarT nm -> do { nm' <- tNameL nm-                         ; mk_apps (HsTyVar noExt NotPromoted nm') tys' }-           ConT nm -> do { nm' <- tconName nm-                         ; -- ConT can contain both data constructor (i.e.,-                           -- promoted) names and other (i.e, unpromoted)-                           -- names, as opposed to PromotedT, which can only-                           -- contain data constructor names. See #15572.-                           let prom = if isRdrDataCon nm'-                                      then IsPromoted-                                      else NotPromoted-                         ; mk_apps (HsTyVar noExt prom (noLoc nm')) tys'}--           ForallT tvs cxt ty-             | null tys'-             -> do { tvs' <- cvtTvs tvs-                   ; cxt' <- cvtContext cxt-                   ; let pcxt = parenthesizeHsContext funPrec cxt'-                   ; ty'  <- cvtType ty-                   ; loc <- getL-                   ; let hs_ty  = mkHsForAllTy tvs loc tvs' rho_ty-                         rho_ty = mkHsQualTy cxt loc pcxt ty'--                   ; return hs_ty }--           SigT ty ki-             -> do { ty' <- cvtType ty-                   ; ki' <- cvtKind ki-                   ; mk_apps (HsKindSig noExt ty' ki') tys'-                   }--           LitT lit-             -> mk_apps (HsTyLit noExt (cvtTyLit lit)) tys'--           WildCardT-             -> mk_apps mkAnonWildCardTy tys'--           InfixT t1 s t2-             -> do { s'  <- tconName s-                   ; t1' <- cvtType t1-                   ; t2' <- cvtType t2-                   ; mk_apps-                      (HsTyVar noExt NotPromoted (noLoc s'))-                      ([HsValArg t1', HsValArg t2'] ++ tys')-                   }--           UInfixT t1 s t2-             -> do { t2' <- cvtType t2-                   ; t <- cvtOpAppT t1 s t2'-                   ; mk_apps (unLoc t) tys'-                   } -- Note [Converting UInfix]--           ParensT t-             -> do { t' <- cvtType t-                   ; mk_apps (HsParTy noExt t') tys'-                   }--           PromotedT nm -> do { nm' <- cName nm-                              ; mk_apps (HsTyVar noExt IsPromoted (noLoc nm'))-                                        tys' }-                 -- Promoted data constructor; hence cName--           PromotedTupleT n-              | n == 1-              -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))-              | Just normals <- m_normals-              , normals `lengthIs` n   -- Saturated-              -> returnL (HsExplicitTupleTy noExt normals)-              | otherwise-              -> mk_apps-                 (HsTyVar noExt IsPromoted (noLoc (getRdrName (tupleDataCon Boxed n))))-                 tys'--           PromotedNilT-             -> mk_apps (HsExplicitListTy noExt IsPromoted []) tys'--           PromotedConsT  -- See Note [Representing concrete syntax in types]-                          -- in Language.Haskell.TH.Syntax-              | Just normals <- m_normals-              , [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- normals-              -> do-                  returnL (HsExplicitListTy noExt ip (ty1:tys2))-              | otherwise-              -> mk_apps-                 (HsTyVar noExt IsPromoted (noLoc (getRdrName consDataCon)))-                 tys'--           StarT-             -> mk_apps-                (HsTyVar noExt NotPromoted (noLoc (getRdrName liftedTypeKindTyCon)))-                tys'--           ConstraintT-             -> mk_apps-                (HsTyVar noExt NotPromoted (noLoc (getRdrName constraintKindTyCon)))-                tys'--           EqualityT-             | Just normals <- m_normals-             , [x',y'] <- normals ->-                   let px = parenthesizeHsType opPrec x'-                       py = parenthesizeHsType opPrec y'-                   in returnL (HsOpTy noExt px (noLoc eqTyCon_RDR) py)-               -- The long-term goal is to remove the above case entirely and-               -- subsume it under the case for InfixT. See #15815, comment:6,-               -- for more details.--             | otherwise ->-                   mk_apps (HsTyVar noExt NotPromoted-                            (noLoc eqTyCon_RDR)) tys'-           ImplicitParamT n t-             -> do { n' <- wrapL $ ipName n-                   ; t' <- cvtType t-                   ; returnL (HsIParamTy noExt n' t')-                   }--           _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))-    }---- | Constructs an application of a type to arguments passed in a list.-mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)-mk_apps head_ty type_args = do-  head_ty' <- returnL head_ty-  -- We must parenthesize the function type in case of an explicit-  -- signature. For instance, in `(Maybe :: Type -> Type) Int`, there-  -- _must_ be parentheses around `Maybe :: Type -> Type`.-  let phead_ty :: LHsType GhcPs-      phead_ty = parenthesizeHsType sigPrec head_ty'--      go :: [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)-      go [] = pure head_ty'-      go (arg:args) =-        case arg of-          HsValArg ty  -> do p_ty <- add_parens ty-                             mk_apps (HsAppTy noExt phead_ty p_ty) args-          HsTypeArg l ki -> do p_ki <- add_parens ki-                               mk_apps (HsAppKindTy l phead_ty p_ki) args-          HsArgPar _   -> mk_apps (HsParTy noExt phead_ty) args--  go type_args-   where-    -- See Note [Adding parens for splices]-    add_parens lt@(dL->L _ t)-      | hsTypeNeedsParens appPrec t = returnL (HsParTy noExt lt)-      | otherwise                   = return lt--wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs-wrap_tyarg (HsValArg ty)    = HsValArg  $ parenthesizeHsType appPrec ty-wrap_tyarg (HsTypeArg l ki) = HsTypeArg l $ parenthesizeHsType appPrec ki-wrap_tyarg ta@(HsArgPar {}) = ta -- Already parenthesized---- ------------------------------------------------------------------------ Note [Adding parens for splices]-{--The hsSyn representation of parsed source explicitly contains all the original-parens, as written in the source.--When a Template Haskell (TH) splice is evaluated, the original splice is first-renamed and type checked and then finally converted to core in DsMeta. This core-is then run in the TH engine, and the result comes back as a TH AST.--In the process, all parens are stripped out, as they are not needed.--This Convert module then converts the TH AST back to hsSyn AST.--In order to pretty-print this hsSyn AST, parens need to be adde back at certain-points so that the code is readable with its original meaning.--So scattered through Convert.hs are various points where parens are added.--See (among other closed issued) https://ghc.haskell.org/trac/ghc/ticket/14289--}--- ------------------------------------------------------------------------- | Constructs an arrow type with a specified return type-mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs)-mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL-    where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs)-          go arg ret_ty = do { ret_ty_l <- returnL ret_ty-                             ; return (HsFunTy noExt arg ret_ty_l) }--split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs])-split_ty_app ty = go ty []-  where-    go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg a':as') }-    go (AppKindT ty ki) as' = do { ki' <- cvtKind ki-                                 ; go ty (HsTypeArg noSrcSpan ki':as') }-    go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') }-    go f as           = return (f,as)--cvtTyLit :: TH.TyLit -> HsTyLit-cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i-cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)--{- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator-application @x `op` y@. The produced tree of infix types will be right-biased,-provided @y@ is.--See the @cvtOpApp@ documentation for how this function works.--}-cvtOpAppT :: TH.Type -> TH.Name -> LHsType GhcPs -> CvtM (LHsType GhcPs)-cvtOpAppT (UInfixT x op2 y) op1 z-  = do { l <- cvtOpAppT y op1 z-       ; cvtOpAppT x op2 l }-cvtOpAppT x op y-  = do { op' <- tconNameL op-       ; x' <- cvtType x-       ; returnL (mkHsOpTy x' op' y) }--cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)-cvtKind = cvtTypeKind "kind"---- | Convert Maybe Kind to a type family result signature. Used with data--- families where naming of the result is not possible (thus only kind or no--- signature is possible).-cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind-                              -> CvtM (LFamilyResultSig GhcPs)-cvtMaybeKindToFamilyResultSig Nothing   = returnL (Hs.NoSig noExt)-cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki-                                             ; returnL (Hs.KindSig noExt ki') }---- | Convert type family result signature. Used with both open and closed type--- families.-cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs)-cvtFamilyResultSig TH.NoSig           = returnL (Hs.NoSig noExt)-cvtFamilyResultSig (TH.KindSig ki)    = do { ki' <- cvtKind ki-                                           ; returnL (Hs.KindSig noExt  ki') }-cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr-                                           ; returnL (Hs.TyVarSig noExt tv) }---- | Convert injectivity annotation of a type family.-cvtInjectivityAnnotation :: TH.InjectivityAnn-                         -> CvtM (Hs.LInjectivityAnn GhcPs)-cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)-  = do { annLHS' <- tNameL annLHS-       ; annRHS' <- mapM tNameL annRHS-       ; returnL (Hs.InjectivityAnn annLHS' annRHS') }--cvtPatSynSigTy :: TH.Type -> CvtM (LHsType GhcPs)--- pattern synonym types are of peculiar shapes, which is why we treat--- them separately from regular types;--- see Note [Pattern synonym type signatures and Template Haskell]-cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))-  | null exis, null provs = cvtType (ForallT univs reqs ty)-  | null univs, null reqs = do { l   <- getL-                               ; ty' <- cvtType (ForallT exis provs ty)-                               ; return $ cL l (HsQualTy { hst_ctxt = cL l []-                                                         , hst_xqual = noExt-                                                         , hst_body = ty' }) }-  | null reqs             = do { l      <- getL-                               ; univs' <- hsQTvExplicit <$> cvtTvs univs-                               ; ty'    <- cvtType (ForallT exis provs ty)-                               ; let forTy = HsForAllTy-                                              { hst_bndrs = univs'-                                              , hst_xforall = noExt-                                              , hst_body = cL l cxtTy }-                                     cxtTy = HsQualTy { hst_ctxt = cL l []-                                                      , hst_xqual = noExt-                                                      , hst_body = ty' }-                               ; return $ cL l forTy }-  | otherwise             = cvtType (ForallT univs reqs (ForallT exis provs ty))-cvtPatSynSigTy ty         = cvtType ty--------------------------------------------------------------cvtFixity :: TH.Fixity -> Hs.Fixity-cvtFixity (TH.Fixity prec dir) = Hs.Fixity NoSourceText prec (cvt_dir dir)-   where-     cvt_dir TH.InfixL = Hs.InfixL-     cvt_dir TH.InfixR = Hs.InfixR-     cvt_dir TH.InfixN = Hs.InfixN------------------------------------------------------------------------------------------------------------------------------ some useful things--overloadedLit :: Lit -> Bool--- True for literals that Haskell treats as overloaded-overloadedLit (IntegerL  _) = True-overloadedLit (RationalL _) = True-overloadedLit _             = False---- Checks that are performed when converting unboxed sum expressions and--- patterns alike.-unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM ()-unboxedSumChecks alt arity-    | alt > arity-    = failWith $ text "Sum alternative"    <+> text (show alt)-             <+> text "exceeds its arity," <+> text (show arity)-    | alt <= 0-    = failWith $ vcat [ text "Illegal sum alternative:" <+> text (show alt)-                      , nest 2 $ text "Sum alternatives must start from 1" ]-    | arity < 2-    = failWith $ vcat [ text "Illegal sum arity:" <+> text (show arity)-                      , nest 2 $ text "Sums must have an arity of at least 2" ]-    | otherwise-    = return ()---- | If passed an empty list of 'TH.TyVarBndr's, this simply returns the--- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy'--- using the provided 'LHsQTyVars' and 'LHsType'.-mkHsForAllTy :: [TH.TyVarBndr]-             -- ^ The original Template Haskell type variable binders-             -> SrcSpan-             -- ^ The location of the returned 'LHsType' if it needs an-             --   explicit forall-             -> LHsQTyVars GhcPs-             -- ^ The converted type variable binders-             -> LHsType GhcPs-             -- ^ The converted rho type-             -> LHsType GhcPs-             -- ^ The complete type, quantified with a forall if necessary-mkHsForAllTy tvs loc tvs' rho_ty-  | null tvs  = rho_ty-  | otherwise = cL loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs'-                                    , hst_xforall = noExt-                                    , hst_body = rho_ty }---- | If passed an empty 'TH.Cxt', this simply returns the third argument--- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided--- 'LHsContext' and 'LHsType'.---- It's important that we don't build an HsQualTy if the context is empty,--- as the pretty-printer for HsType _always_ prints contexts, even if--- they're empty. See Trac #13183.-mkHsQualTy :: TH.Cxt-           -- ^ The original Template Haskell context-           -> SrcSpan-           -- ^ The location of the returned 'LHsType' if it needs an-           --   explicit context-           -> LHsContext GhcPs-           -- ^ The converted context-           -> LHsType GhcPs-           -- ^ The converted tau type-           -> LHsType GhcPs-           -- ^ The complete type, qualified with a context if necessary-mkHsQualTy ctxt loc ctxt' ty-  | null ctxt = ty-  | otherwise = cL loc $ HsQualTy { hst_xqual = noExt-                                  , hst_ctxt  = ctxt'-                                  , hst_body  = ty }-------------------------------------------------------------------------      Turning Name back into RdrName------------------------------------------------------------------------- variable names-vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)-vName,  cName,  vcName,  tName,  tconName  :: TH.Name -> CvtM RdrName---- Variable names-vNameL n = wrapL (vName n)-vName n = cvtName OccName.varName n---- Constructor function names; this is Haskell source, hence srcDataName-cNameL n = wrapL (cName n)-cName n = cvtName OccName.dataName n---- Variable *or* constructor names; check by looking at the first char-vcNameL n = wrapL (vcName n)-vcName n = if isVarName n then vName n else cName n---- Type variable names-tNameL n = wrapL (tName n)-tName n = cvtName OccName.tvName n---- Type Constructor names-tconNameL n = wrapL (tconName n)-tconName n = cvtName OccName.tcClsName n--ipName :: String -> CvtM HsIPName-ipName n-  = do { unless (okVarOcc n) (failWith (badOcc OccName.varName n))-       ; return (HsIPName (fsLit n)) }--cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName-cvtName ctxt_ns (TH.Name occ flavour)-  | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)-  | otherwise-  = do { loc <- getL-       ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour-       ; force rdr_name-       ; return rdr_name }-  where-    occ_str = TH.occString occ--okOcc :: OccName.NameSpace -> String -> Bool-okOcc ns str-  | OccName.isVarNameSpace ns     = okVarOcc str-  | OccName.isDataConNameSpace ns = okConOcc str-  | otherwise                     = okTcOcc  str---- Determine the name space of a name in a type----isVarName :: TH.Name -> Bool-isVarName (TH.Name occ _)-  = case TH.occString occ of-      ""    -> False-      (c:_) -> startsVarId c || startsVarSym c--badOcc :: OccName.NameSpace -> String -> SDoc-badOcc ctxt_ns occ-  = text "Illegal" <+> pprNameSpace ctxt_ns-        <+> text "name:" <+> quotes (text occ)--thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName--- This turns a TH Name into a RdrName; used for both binders and occurrences--- See Note [Binders in Template Haskell]--- The passed-in name space tells what the context is expecting;---      use it unless the TH name knows what name-space it comes---      from, in which case use the latter------ We pass in a SrcSpan (gotten from the monad) because this function--- is used for *binders* and if we make an Exact Name we want it--- to have a binding site inside it.  (cf Trac #5434)------ ToDo: we may generate silly RdrNames, by passing a name space---       that doesn't match the string, like VarName ":+",---       which will give confusing error messages later------ The strict applications ensure that any buried exceptions get forced-thRdrName loc ctxt_ns th_occ th_name-  = case th_name of-     TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod-     TH.NameQ mod  -> (mkRdrQual  $! mk_mod mod) $! occ-     TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq uniq) $! occ) loc)-     TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq uniq) $! occ) loc)-     TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name-              | otherwise                           -> mkRdrUnqual $! occ-              -- We check for built-in syntax here, because the TH-              -- user might have written a (NameS "(,,)"), for example-  where-    occ :: OccName.OccName-    occ = mk_occ ctxt_ns th_occ---- Return an unqualified exact RdrName if we're dealing with built-in syntax.--- See Trac #13776.-thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName-thOrigRdrName occ th_ns pkg mod =-  let occ' = mk_occ (mk_ghc_ns th_ns) occ-  in case isBuiltInOcc_maybe occ' of-       Just name -> nameRdrName name-       Nothing   -> (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! occ'--thRdrNameGuesses :: TH.Name -> [RdrName]-thRdrNameGuesses (TH.Name occ flavour)-  -- This special case for NameG ensures that we don't generate duplicates in the output list-  | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod]-  | otherwise                         = [ thRdrName noSrcSpan gns occ_str flavour-                                        | gns <- guessed_nss]-  where-    -- guessed_ns are the name spaces guessed from looking at the TH name-    guessed_nss-      | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]-      | otherwise                       = [OccName.varName, OccName.tvName]-    occ_str = TH.occString occ---- The packing and unpacking is rather turgid :-(-mk_occ :: OccName.NameSpace -> String -> OccName.OccName-mk_occ ns occ = OccName.mkOccName ns occ--mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace-mk_ghc_ns TH.DataName  = OccName.dataName-mk_ghc_ns TH.TcClsName = OccName.tcClsName-mk_ghc_ns TH.VarName   = OccName.varName--mk_mod :: TH.ModName -> ModuleName-mk_mod mod = mkModuleName (TH.modString mod)--mk_pkg :: TH.PkgName -> UnitId-mk_pkg pkg = stringToUnitId (TH.pkgString pkg)--mk_uniq :: Int -> Unique-mk_uniq u = mkUniqueGrimily u--{--Note [Binders in Template Haskell]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this TH term construction:-  do { x1 <- TH.newName "x"   -- newName :: String -> Q TH.Name-     ; x2 <- TH.newName "x"   -- Builds a NameU-     ; x3 <- TH.newName "x"--     ; let x = mkName "x"     -- mkName :: String -> TH.Name-                              -- Builds a NameS--     ; return (LamE (..pattern [x1,x2]..) $-               LamE (VarPat x3) $-               ..tuple (x1,x2,x3,x)) }--It represents the term   \[x1,x2]. \x3. (x1,x2,x3,x)--a) We don't want to complain about "x" being bound twice in-   the pattern [x1,x2]-b) We don't want x3 to shadow the x1,x2-c) We *do* want 'x' (dynamically bound with mkName) to bind-   to the innermost binding of "x", namely x3.-d) When pretty printing, we want to print a unique with x1,x2-   etc, else they'll all print as "x" which isn't very helpful--When we convert all this to HsSyn, the TH.Names are converted with-thRdrName.  To achieve (b) we want the binders to be Exact RdrNames.-Achieving (a) is a bit awkward, because-   - We must check for duplicate and shadowed names on Names,-     not RdrNames, *after* renaming.-     See Note [Collect binders only after renaming] in HsUtils--   - But to achieve (a) we must distinguish between the Exact-     RdrNames arising from TH and the Unqual RdrNames that would-     come from a user writing \[x,x] -> blah--So in Convert.thRdrName we translate-   TH Name                          RdrName-   ---------------------------------------------------------   NameU (arising from newName) --> Exact (Name{ System })-   NameS (arising from mkName)  --> Unqual--Notice that the NameUs generate *System* Names.  Then, when-figuring out shadowing and duplicates, we can filter out-System Names.--This use of System Names fits with other uses of System Names, eg for-temporary variables "a". Since there are lots of things called "a" we-usually want to print the name with the unique, and that is indeed-the way System Names are printed.--There's a small complication of course; see Note [Looking up Exact-RdrNames] in RnEnv.--}--{--Note [Pattern synonym type signatures and Template Haskell]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--In general, the type signature of a pattern synonym--  pattern P x1 x2 .. xn = <some-pattern>--is of the form--   forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t--with the following parts:--   1) the (possibly empty lists of) universally quantified type-      variables `univs` and required constraints `reqs` on them.-   2) the (possibly empty lists of) existentially quantified type-      variables `exis` and the provided constraints `provs` on them.-   3) the types `t1`, `t2`, .., `tn` of the pattern synonym's arguments x1,-      x2, .., xn, respectively-   4) the type `t` of <some-pattern>, mentioning only universals from `univs`.--Due to the two forall quantifiers and constraint contexts (either of-which might be empty), pattern synonym type signatures are treated-specially in `deSugar/DsMeta.hs`, `hsSyn/Convert.hs`, and-`typecheck/TcSplice.hs`:--   (a) When desugaring a pattern synonym from HsSyn to TH.Dec in-       `deSugar/DsMeta.hs`, we represent its *full* type signature in TH, i.e.:--           ForallT univs reqs (ForallT exis provs ty)-              (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)--   (b) When converting pattern synonyms from TH.Dec to HsSyn in-       `hsSyn/Convert.hs`, we convert their TH type signatures back to an-       appropriate Haskell pattern synonym type of the form--         forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t--       where initial empty `univs` type variables or an empty `reqs`-       constraint context are represented *explicitly* as `() =>`.--   (c) When reifying a pattern synonym in `typecheck/TcSplice.hs`, we always-       return its *full* type, i.e.:--           ForallT univs reqs (ForallT exis provs ty)-              (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)--The key point is to always represent a pattern synonym's *full* type-in cases (a) and (c) to make it clear which of the two forall-quantifiers and/or constraint contexts are specified, and which are-not. See GHC's user's guide on pattern synonyms for more information-about pattern synonym type signatures.---}
compiler/iface/BinIface.hs view
@@ -10,6 +10,7 @@  -- | Binary interface file support. module BinIface (+        -- * Public API for interface file serialisation         writeBinIface,         readBinIface,         getSymtabName,@@ -17,11 +18,20 @@         CheckHiWay(..),         TraceBinIFaceReading(..),         getWithUserData,-        putWithUserData+        putWithUserData, +        -- * Internal serialisation functions+        getSymbolTable,+        putName,+        putDictionary,+        putFastString,+        putSymbolTable,+        BinSymbolTable(..),+        BinDictionary(..)+     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -42,7 +52,7 @@ import Unique import Outputable import NameCache-import Platform+import GHC.Platform import FastString import Constants import Util@@ -92,11 +102,12 @@                                     (defaultDumpStyle dflags)                                     sd                       QuietBinIFaceReading -> \_ -> return ()-        wantedGot :: Outputable a => String -> a -> a -> IO ()-        wantedGot what wanted got =++        wantedGot :: String -> a -> a -> (a -> SDoc) -> IO ()+        wantedGot what wanted got ppr' =             printer (text what <> text ": " <>-                     vcat [text "Wanted " <> ppr wanted <> text ",",-                           text "got    " <> ppr got])+                     vcat [text "Wanted " <> ppr' wanted <> text ",",+                           text "got    " <> ppr' got])          errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()         errorOnMismatch what wanted got =@@ -111,7 +122,7 @@     -- (This magic number does not change when we change     --  GHC interface file format)     magic <- get bh-    wantedGot "Magic" (binaryInterfaceMagic dflags) magic+    wantedGot "Magic" (binaryInterfaceMagic dflags) magic ppr     errorOnMismatch "magic number mismatch: old/corrupt interface file?"         (binaryInterfaceMagic dflags) magic @@ -129,12 +140,12 @@     -- Check the interface file version and ways.     check_ver  <- get bh     let our_ver = show hiVersion-    wantedGot "Version" our_ver check_ver+    wantedGot "Version" our_ver check_ver text     errorOnMismatch "mismatched interface file versions" our_ver check_ver      check_way <- get bh     let way_descr = getWayDescr dflags-    wantedGot "Way" way_descr check_way+    wantedGot "Way" way_descr check_way ppr     when (checkHiWay == CheckHiWay) $         errorOnMismatch "mismatched interface file ways" way_descr check_way     getWithUserData ncu bh
compiler/iface/BuildTyCl.hs view
@@ -13,7 +13,7 @@         newImplicitBinder, newTyConRepName     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -54,12 +54,14 @@         ; return (NewTyCon { data_con    = con,                              nt_rhs      = rhs_ty,                              nt_etad_rhs = (etad_tvs, etad_rhs),-                             nt_co       = nt_ax } ) }+                             nt_co       = nt_ax,+                             nt_lev_poly = isKindLevPoly res_kind } ) }                              -- Coreview looks through newtypes with a Nothing                              -- for nt_co, or uses explicit coercions otherwise   where-    tvs    = tyConTyVars tycon-    roles  = tyConRoles tycon+    tvs      = tyConTyVars tycon+    roles    = tyConRoles tycon+    res_kind = tyConResKind tycon     con_arg_ty = case dataConRepArgTys con of                    [arg_ty] -> arg_ty                    tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys)@@ -247,8 +249,7 @@     do  { traceIf (text "buildClass")          ; tc_rep_name  <- newTyConRepName tycon_name-        ; let univ_bndrs = tyConTyVarBinders binders-              univ_tvs   = binderVars univ_bndrs+        ; let univ_tvs = binderVars binders               tycon = mkClassTyCon tycon_name binders roles                                    AbstractTyCon rec_clas tc_rep_name               result = mkAbstractClass tycon_name univ_tvs fds tycon@@ -371,7 +372,7 @@  We cannot represent this by a newtype, even though it's not existential, because there are two value fields (the equality-predicate and op. See Trac #2238+predicate and op. See #2238  Moreover,           class (a ~ F b) => C a b where {}
compiler/iface/FlagChecker.hs view
@@ -11,7 +11,6 @@ import GhcPrelude  import Binary-import BinIface () import DynFlags import HscTypes import Module@@ -58,8 +57,12 @@         -- -fprof-auto etc.         prof = if gopt Opt_SccProfilingOn dflags then fromEnum profAuto else 0 -        flags = (mainis, safeHs, lang, cpp, paths, prof)+        -- Ticky+        ticky =+          map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk] +        flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, debugLevel))+     in -- pprTrace "flags" (ppr flags) $        computeFingerprint nameio flags @@ -73,7 +76,7 @@                       -> IO Fingerprint fingerprintOptFlags DynFlags{..} nameio =       let-        -- See https://ghc.haskell.org/trac/ghc/ticket/10923+        -- See https://gitlab.haskell.org/ghc/ghc/issues/10923         -- We used to fingerprint the optimisation level, but as Joachim         -- Breitner pointed out in comment 9 on that ticket, it's better         -- to ignore that and just look at the individual optimisation flags.@@ -91,7 +94,7 @@                       -> IO Fingerprint fingerprintHpcFlags dflags@DynFlags{..} nameio =       let-        -- -fhpc, see https://ghc.haskell.org/trac/ghc/ticket/11798+        -- -fhpc, see https://gitlab.haskell.org/ghc/ghc/issues/11798         -- hpcDir is output-only, so we should recompile if it changes         hpc = if gopt Opt_Hpc dflags then Just hpcDir else Nothing
compiler/iface/IfaceEnv.hs view
@@ -20,7 +20,7 @@         mkNameCacheUpdater, NameCacheUpdater(..),    ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude
compiler/iface/LoadIface.hs view
@@ -7,6 +7,7 @@ -}  {-# LANGUAGE CPP, BangPatterns, RecordWildCards, NondecreasingIndentation #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module LoadIface (         -- Importing one thing@@ -31,7 +32,7 @@         ifaceStats, pprModIface, showIface    ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -155,7 +156,7 @@   where     nd_doc = text "Need decl for" <+> ppr name     not_found_msg = hang (text "Can't find interface-file declaration for" <+>-                                pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name)+                                pprNameSpace (nameNameSpace name) <+> ppr name)                        2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file",                                 text "Use -ddump-if-trace to get an idea of which file caused the error"])     found_things_msg eps =@@ -399,7 +400,8 @@        -- Redo search for our local hole module        loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from   | otherwise-  = do  {       -- Read the state+  = withTimingSilentD (text "loading interface") (pure ()) $+    do  {       -- Read the state           (eps,hpt) <- getEpsAndHpt         ; gbl_env <- getGblEnv @@ -407,7 +409,7 @@                  -- Check whether we have the interface already         ; dflags <- getDynFlags-        ; case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of {+        ; case lookupIfaceByModule hpt (eps_PIT eps) mod of {             Just iface                 -> return (Succeeded iface) ;   -- Already loaded                         -- The (src_imp == mi_boot iface) test checks that the already-loaded@@ -421,7 +423,7 @@                            Succeeded hi_boot_file -> computeInterface doc_str hi_boot_file mod         ; case read_result of {             Failed err -> do-                { let fake_iface = emptyModIface mod+                { let fake_iface = emptyFullModIface mod                  ; updateEps_ $ \eps ->                         eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface }@@ -673,14 +675,13 @@         traceIf (text "Considering whether to load" <+> ppr mod <+>                  text "to compute precise free module holes")         (eps, hpt) <- getEpsAndHpt-        dflags <- getDynFlags-        case tryEpsAndHpt dflags eps hpt `firstJust` tryDepsCache eps imod insts of+        case tryEpsAndHpt eps hpt `firstJust` tryDepsCache eps imod insts of             Just r -> return (Succeeded r)             Nothing -> readAndCache imod insts     (_, Nothing) -> return (Succeeded emptyUniqDSet)   where-    tryEpsAndHpt dflags eps hpt =-        fmap mi_free_holes (lookupIfaceByModule dflags hpt (eps_PIT eps) mod)+    tryEpsAndHpt eps hpt =+        fmap mi_free_holes (lookupIfaceByModule hpt (eps_PIT eps) mod)     tryDepsCache eps imod insts =         case lookupInstalledModuleEnv (eps_free_holes eps) imod of             Just ifhs  -> Just (renameFreeHoles ifhs insts)@@ -876,7 +877,7 @@     is a home-package module which is not yet in the HPT!  Disaster.  This actually happened with P=base, Q=ghc-prim, via the AMP warnings.-See Trac #8320.+See #8320. -}  findAndReadIface :: SDoc@@ -964,7 +965,7 @@                   r <- read_file dynFilePath                   case r of                       Succeeded (dynIface, _)-                       | mi_mod_hash iface == mi_mod_hash dynIface ->+                       | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) ->                           return ()                        | otherwise ->                           do traceIf (text "Dynamic hash doesn't match")@@ -1038,13 +1039,15 @@  ghcPrimIface :: ModIface ghcPrimIface-  = (emptyModIface gHC_PRIM) {+  = empty_iface {         mi_exports  = ghcPrimExports,         mi_decls    = [],         mi_fixities = fixities,-        mi_fix_fn  = mkIfaceFixCache fixities-    }+        mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities }+        }   where+    empty_iface = emptyFullModIface gHC_PRIM+     -- The fixities listed here for @`seq`@ or @->@ should match     -- those in primops.txt.pp (from which Haddock docs are generated).     fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR)@@ -1117,21 +1120,21 @@  pprModIface :: ModIface -> SDoc -- Show a ModIface-pprModIface iface+pprModIface iface@ModIface{ mi_final_exts = exts }  = vcat [ text "interface"                 <+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface)-                <+> (if mi_orphan iface then text "[orphan module]" else Outputable.empty)-                <+> (if mi_finsts iface then text "[family instance module]" else Outputable.empty)-                <+> (if mi_hpc    iface then text "[hpc]" else Outputable.empty)+                <+> (if mi_orphan exts then text "[orphan module]" else Outputable.empty)+                <+> (if mi_finsts exts then text "[family instance module]" else Outputable.empty)+                <+> (if mi_hpc iface then text "[hpc]" else Outputable.empty)                 <+> integer hiVersion-        , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash iface))-        , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface))-        , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface))-        , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface))-        , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash iface))-        , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash iface))-        , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash iface))-        , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash iface))+        , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash exts))+        , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash exts))+        , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash exts))+        , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash exts))+        , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash exts))+        , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash exts))+        , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash exts))+        , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash exts))         , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface))         , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface))         , nest 2 (text "where")
compiler/iface/MkIface.hs view
@@ -10,8 +10,8 @@ -- writing them to disk and comparing two versions to see if -- recompilation is required. module MkIface (-        mkIface,        -- Build a ModIface from a ModGuts,-                        -- including computing version information+        mkPartialIface,+        mkFullIface,          mkIfaceTc, @@ -34,7 +34,7 @@ A complete description of how recompilation checking works can be found in the wiki commentary: - http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance+ https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance  Please read the above page for a top-down description of how this all works.  Notes below cover specific issues related to the implementation.@@ -58,7 +58,7 @@     the actual fingerprint for all each thing recorded in mi_usages -} -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -82,7 +82,7 @@ import InstEnv import FamInstEnv import TcRnMonad-import HsSyn+import GHC.Hs import HscTypes import Finder import DynFlags@@ -113,8 +113,9 @@  import Control.Monad import Data.Function-import Data.List+import Data.List (find, findIndex, mapAccumL, sortBy, sort) import qualified Data.Map as Map+import qualified Data.Set as Set import Data.Ord import Data.IORef import System.Directory@@ -134,48 +135,51 @@ ************************************************************************ -} -mkIface :: HscEnv-        -> Maybe Fingerprint    -- The old fingerprint, if we have it-        -> ModDetails           -- The trimmed, tidied interface-        -> ModGuts              -- Usages, deprecations, etc-        -> IO (ModIface, -- The new one-               Bool)     -- True <=> there was an old Iface, and the-                         --          new one is identical, so no need-                         --          to write it+mkPartialIface :: HscEnv+               -> ModDetails+               -> ModGuts+               -> PartialModIface+mkPartialIface hsc_env mod_details+  ModGuts{ mg_module       = this_mod+         , mg_hsc_src      = hsc_src+         , mg_usages       = usages+         , mg_used_th      = used_th+         , mg_deps         = deps+         , mg_rdr_env      = rdr_env+         , mg_fix_env      = fix_env+         , mg_warns        = warns+         , mg_hpc_info     = hpc_info+         , mg_safe_haskell = safe_mode+         , mg_trust_pkg    = self_trust+         , mg_doc_hdr      = doc_hdr+         , mg_decl_docs    = decl_docs+         , mg_arg_docs     = arg_docs+         }+  = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust+             safe_mode usages doc_hdr decl_docs arg_docs mod_details -mkIface hsc_env maybe_old_fingerprint mod_details-         ModGuts{     mg_module       = this_mod,-                      mg_hsc_src      = hsc_src,-                      mg_usages       = usages,-                      mg_used_th      = used_th,-                      mg_deps         = deps,-                      mg_rdr_env      = rdr_env,-                      mg_fix_env      = fix_env,-                      mg_warns        = warns,-                      mg_hpc_info     = hpc_info,-                      mg_safe_haskell = safe_mode,-                      mg_trust_pkg    = self_trust,-                      mg_doc_hdr      = doc_hdr,-                      mg_decl_docs    = decl_docs,-                      mg_arg_docs     = arg_docs-                    }-        = mkIface_ hsc_env maybe_old_fingerprint-                   this_mod hsc_src used_th deps rdr_env fix_env-                   warns hpc_info self_trust-                   safe_mode usages-                   doc_hdr decl_docs arg_docs-                   mod_details+-- | Fully instantiate a interface+-- Adds fingerprints and potentially code generator produced information.+mkFullIface :: HscEnv -> PartialModIface -> IO ModIface+mkFullIface hsc_env partial_iface = do+    full_iface <-+      {-# SCC "addFingerprints" #-}+      addFingerprints hsc_env partial_iface --- | make an interface from the results of typechecking only.  Useful+    -- Debug printing+    dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" (pprModIface full_iface)++    return full_iface++-- | Make an interface from the results of typechecking only.  Useful -- for non-optimising compilation, or where we aren't generating any -- object code at all ('HscNothing'). mkIfaceTc :: HscEnv-          -> Maybe Fingerprint  -- The old fingerprint, if we have it           -> SafeHaskellMode    -- The safe haskell mode           -> ModDetails         -- gotten from mkBootModDetails, probably           -> TcGblEnv           -- Usages, deprecations, etc-          -> IO (ModIface, Bool)-mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details+          -> IO ModIface+mkIfaceTc hsc_env safe_mode mod_details   tc_result@TcGblEnv{ tcg_mod = this_mod,                       tcg_src = hsc_src,                       tcg_imports = imports,@@ -209,7 +213,7 @@            let (doc_hdr', doc_map, arg_map) = extractDocs tc_result -          mkIface_ hsc_env maybe_old_fingerprint+          let partial_iface = mkIface_ hsc_env                    this_mod hsc_src                    used_th deps rdr_env                    fix_env warns hpc_info@@ -217,9 +221,9 @@                    doc_hdr' doc_map arg_map                    mod_details -+          mkFullIface hsc_env partial_iface -mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource+mkIface_ :: HscEnv -> Module -> HscSource          -> Bool -> Dependencies -> GlobalRdrEnv          -> NameEnv FixItem -> Warnings -> HpcInfo          -> Bool@@ -229,8 +233,8 @@          -> DeclDocMap          -> ArgDocMap          -> ModDetails-         -> IO (ModIface, Bool)-mkIface_ hsc_env maybe_old_fingerprint+         -> PartialModIface+mkIface_ hsc_env          this_mod hsc_src used_th deps rdr_env fix_env src_warns          hpc_info pkg_trust_req safe_mode usages          doc_hdr decl_docs arg_docs@@ -276,72 +280,38 @@         annotations = map mkIfaceAnnotation anns         icomplete_sigs = map mkIfaceCompleteSig complete_sigs -        intermediate_iface = ModIface {-              mi_module      = this_mod,-              -- Need to record this because it depends on the -instantiated-with flag-              -- which could change-              mi_sig_of      = if semantic_mod == this_mod-                                then Nothing-                                else Just semantic_mod,-              mi_hsc_src     = hsc_src,-              mi_deps        = deps,-              mi_usages      = usages,-              mi_exports     = mkIfaceExports exports,--              -- Sort these lexicographically, so that-              -- the result is stable across compilations-              mi_insts       = sortBy cmp_inst     iface_insts,-              mi_fam_insts   = sortBy cmp_fam_inst iface_fam_insts,-              mi_rules       = sortBy cmp_rule     iface_rules,--              mi_fixities    = fixities,-              mi_warns       = warns,-              mi_anns        = annotations,-              mi_globals     = maybeGlobalRdrEnv rdr_env,--              -- Left out deliberately: filled in by addFingerprints-              mi_iface_hash  = fingerprint0,-              mi_mod_hash    = fingerprint0,-              mi_flag_hash   = fingerprint0,-              mi_opt_hash    = fingerprint0,-              mi_hpc_hash    = fingerprint0,-              mi_exp_hash    = fingerprint0,-              mi_plugin_hash = fingerprint0,-              mi_used_th     = used_th,-              mi_orphan_hash = fingerprint0,-              mi_orphan      = False, -- Always set by addFingerprints, but-                                      -- it's a strict field, so we can't omit it.-              mi_finsts      = False, -- Ditto-              mi_decls       = deliberatelyOmitted "decls",-              mi_hash_fn     = deliberatelyOmitted "hash_fn",-              mi_hpc         = isHpcUsed hpc_info,-              mi_trust       = trust_info,-              mi_trust_pkg   = pkg_trust_req,--              -- And build the cached values-              mi_warn_fn     = mkIfaceWarnCache warns,-              mi_fix_fn      = mkIfaceFixCache fixities,-              mi_complete_sigs = icomplete_sigs,-              mi_doc_hdr     = doc_hdr,-              mi_decl_docs   = decl_docs,-              mi_arg_docs    = arg_docs }--    (new_iface, no_change_at_all)-          <- {-# SCC "versioninfo" #-}-                   addFingerprints hsc_env maybe_old_fingerprint-                                   intermediate_iface decls--    -- Debug printing-    dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"-                  (pprModIface new_iface)+    ModIface {+          mi_module      = this_mod,+          -- Need to record this because it depends on the -instantiated-with flag+          -- which could change+          mi_sig_of      = if semantic_mod == this_mod+                            then Nothing+                            else Just semantic_mod,+          mi_hsc_src     = hsc_src,+          mi_deps        = deps,+          mi_usages      = usages,+          mi_exports     = mkIfaceExports exports, -    -- bug #1617: on reload we weren't updating the PrintUnqualified-    -- correctly.  This stems from the fact that the interface had-    -- not changed, so addFingerprints returns the old ModIface-    -- with the old GlobalRdrEnv (mi_globals).-    let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env }+          -- Sort these lexicographically, so that+          -- the result is stable across compilations+          mi_insts       = sortBy cmp_inst     iface_insts,+          mi_fam_insts   = sortBy cmp_fam_inst iface_fam_insts,+          mi_rules       = sortBy cmp_rule     iface_rules, -    return (final_iface, no_change_at_all)+          mi_fixities    = fixities,+          mi_warns       = warns,+          mi_anns        = annotations,+          mi_globals     = maybeGlobalRdrEnv rdr_env,+          mi_used_th     = used_th,+          mi_decls       = decls,+          mi_hpc         = isHpcUsed hpc_info,+          mi_trust       = trust_info,+          mi_trust_pkg   = pkg_trust_req,+          mi_complete_sigs = icomplete_sigs,+          mi_doc_hdr     = doc_hdr,+          mi_decl_docs   = decl_docs,+          mi_arg_docs    = arg_docs,+          mi_final_exts        = () }   where      cmp_rule     = comparing ifRuleName      -- Compare these lexicographically by OccName, *not* by unique,@@ -362,9 +332,6 @@          | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env          | otherwise                                   = Nothing -     deliberatelyOmitted :: String -> a-     deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)-      ifFamInstTcName = ifFamInstFam  -----------------------------@@ -398,7 +365,7 @@       orig_mod = nameModule name       lookup mod = do         MASSERT2( isExternalName name, ppr name )-        iface <- case lookupIfaceByModule dflags hpt pit mod of+        iface <- case lookupIfaceByModule hpt pit mod of                   Just iface -> return iface                   Nothing -> do                       -- This can occur when we're writing out ifaces for@@ -408,7 +375,7 @@                       iface <- initIfaceLoad hsc_env . withException                             $ loadInterface (text "lookupVers2") mod ImportBySystem                       return iface-        return $ snd (mi_hash_fn iface occ `orElse`+        return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse`                   pprPanic "lookupVers1" (ppr mod <+> ppr occ))  -- ---------------------------------------------------------------------------@@ -442,17 +409,16 @@ -- See Note [Fingerprinting IfaceDecls] addFingerprints         :: HscEnv-        -> Maybe Fingerprint -- the old fingerprint, if any-        -> ModIface          -- The new interface (lacking decls)-        -> [IfaceDecl]       -- The new decls-        -> IO (ModIface,     -- Updated interface-               Bool)         -- True <=> no changes at all;-                             -- no need to write Iface--addFingerprints hsc_env mb_old_fingerprint iface0 new_decls+        -> PartialModIface+        -> IO ModIface+addFingerprints hsc_env iface0  = do    eps <- hscEPS hsc_env    let+       decls = mi_decls iface0+       warn_fn = mkIfaceWarnCache (mi_warns iface0)+       fix_fn = mkIfaceFixCache (mi_fixities iface0)+         -- The ABI of a declaration represents everything that is made         -- visible about the declaration that a client can depend on.         -- see IfaceDeclABI below.@@ -467,7 +433,7 @@        -- from its OccName. See Note [default method Name]        top_lvl_name_env =          mkOccEnv [ (nameOccName nm, nm)-                  | IfaceId { ifName = nm } <- new_decls ]+                  | IfaceId { ifName = nm } <- decls ]         -- Dependency edges between declarations in the current module.        -- This is computed by finding the free external names of each@@ -475,7 +441,7 @@        -- declaration implicitly depends on).        edges :: [ Node Unique IfaceDeclABI ]        edges = [ DigraphNode abi (getUnique (getOccName decl)) out-               | decl <- new_decls+               | decl <- decls                , let abi = declABI decl                , let out = localOccs $ freeNamesDeclABI abi                ]@@ -500,7 +466,7 @@         -- e.g. a reference to a constructor must be turned into a reference         -- to the TyCon for the purposes of calculating dependencies.        parent_map :: OccEnv OccName-       parent_map = foldl' extend emptyOccEnv new_decls+       parent_map = foldl' extend emptyOccEnv decls           where extend env d =                   extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ]                   where n = getOccName d@@ -625,7 +591,7 @@     -- Note [Do not update EPS with your own hi-boot]    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-   -- (See also Trac #10182).  When your hs-boot file includes an orphan+   -- (See also #10182).  When your hs-boot file includes an orphan    -- instance declaration, you may find that the dep_orphs of a module you    -- import contains reference to yourself.  DO NOT actually load this module    -- or add it to the orphan hashes: you're going to provide the orphan@@ -645,7 +611,7 @@                        -- See Note [Export hash depends on non-orphan family instances]                        dep_finsts (mi_deps iface0),                         -- dep_pkgs: see "Package Version Changes" on-                        -- wiki/Commentary/Compiler/RecompilationAvoidance+                        -- wiki/commentary/compiler/recompilation-avoidance                        mi_trust iface0)                         -- Make sure change of Safe Haskell mode causes recomp. @@ -718,26 +684,27 @@                        mi_hpc iface0)     let-    no_change_at_all = Just iface_hash == mb_old_fingerprint--    final_iface = iface0 {-                mi_mod_hash    = mod_hash,-                mi_iface_hash  = iface_hash,-                mi_exp_hash    = export_hash,-                mi_orphan_hash = orphan_hash,-                mi_flag_hash   = flag_hash,-                mi_opt_hash    = opt_hash,-                mi_hpc_hash    = hpc_hash,-                mi_plugin_hash = plugin_hash,-                mi_orphan      = not (   all ifRuleAuto orph_rules-                                           -- See Note [Orphans and auto-generated rules]-                                      && null orph_insts-                                      && null orph_fis),-                mi_finsts      = not . null $ mi_fam_insts iface0,-                mi_decls       = sorted_decls,-                mi_hash_fn     = lookupOccEnv local_env }+    final_iface_exts = ModIfaceBackend+      { mi_iface_hash  = iface_hash+      , mi_mod_hash    = mod_hash+      , mi_flag_hash   = flag_hash+      , mi_opt_hash    = opt_hash+      , mi_hpc_hash    = hpc_hash+      , mi_plugin_hash = plugin_hash+      , mi_orphan      = not (   all ifRuleAuto orph_rules+                                   -- See Note [Orphans and auto-generated rules]+                              && null orph_insts+                              && null orph_fis)+      , mi_finsts      = not (null (mi_fam_insts iface0))+      , mi_exp_hash    = export_hash+      , mi_orphan_hash = orphan_hash+      , mi_warn_fn     = warn_fn+      , mi_fix_fn      = fix_fn+      , mi_hash_fn     = lookupOccEnv local_env+      }+    final_iface = iface0 { mi_decls = sorted_decls, mi_final_exts = final_iface_exts }    ---   return (final_iface, no_change_at_all)+   return final_iface    where     this_mod = mi_module iface0@@ -746,7 +713,6 @@     (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph    (mi_insts iface0)     (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph    (mi_rules iface0)     (non_orph_fis,   orph_fis)   = mkOrphMap ifFamInstOrph (mi_fam_insts iface0)-    fix_fn = mi_fix_fn iface0     ann_fn = mkIfaceAnnCache (mi_anns iface0)  -- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules@@ -785,14 +751,13 @@   let     hpt        = hsc_HPT hsc_env     pit        = eps_PIT eps-    dflags     = hsc_dflags hsc_env     get_orph_hash mod =-          case lookupIfaceByModule dflags hpt pit mod of-            Just iface -> return (mi_orphan_hash iface)+          case lookupIfaceByModule hpt pit mod of+            Just iface -> return (mi_orphan_hash (mi_final_exts iface))             Nothing    -> do -- similar to 'mkHashFun'                 iface <- initIfaceLoad hsc_env . withException                             $ loadInterface (text "getOrphanHashes") mod ImportBySystem-                return (mi_orphan_hash iface)+                return (mi_orphan_hash (mi_final_exts iface))    --   mapM get_orph_hash mods@@ -991,7 +956,7 @@             insts = (map ifDFun $ (concatMap at_extras ats)                                     ++ lookupOccEnvL inst_env n)                            -- Include instances of the associated types-                           -- as well as instances of the class (Trac #5147)+                           -- as well as instances of the class (#5147)             meths = [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs]             -- Names of all the default methods (see Note [default method Name])             defms = [ dmName@@ -1136,7 +1101,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~ Most of the used_names are External Names, but we can have Internal Names too: see Note [Binders in Template Haskell] in Convert, and-Trac #5362 for an example.  Such Names are always+#5362 for an example.  Such Names are always   - Such Names are always for locally-defined things, for which we     don't gather usage info, so we can just ignore them in ent_map   - They are always System Names, hence the assert, just as a double check.@@ -1177,8 +1142,8 @@ -- is equivalent to the current source file the user asked us to compile. -- If the same, we can avoid recompilation. We return a tuple where the -- first element is a bool saying if we should recompile the object file--- and the second is maybe the interface file, where Nothng means to--- rebuild the interface file not use the exisitng one.+-- and the second is maybe the interface file, where Nothing means to+-- rebuild the interface file and not use the existing one. checkOldIface   :: HscEnv   -> ModSummary@@ -1326,7 +1291,7 @@ checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired checkPlugins hsc iface = liftIO $ do   new_fingerprint <- fingerprintPlugins hsc-  let old_fingerprint = mi_plugin_hash iface+  let old_fingerprint = mi_plugin_hash (mi_final_exts iface)   pr <- mconcat <$> mapM pluginRecompile' (plugins (hsc_dflags hsc))   return $     pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr@@ -1423,7 +1388,7 @@ -- | Check the flags haven't changed checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired checkFlagHash hsc_env iface = do-    let old_hash = mi_flag_hash iface+    let old_hash = mi_flag_hash (mi_final_exts iface)     new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env)                                              (mi_module iface)                                              putNameLiterally@@ -1436,7 +1401,7 @@ -- | Check the optimisation flags haven't changed checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired checkOptimHash hsc_env iface = do-    let old_hash = mi_opt_hash iface+    let old_hash = mi_opt_hash (mi_final_exts iface)     new_hash <- liftIO $ fingerprintOptFlags (hsc_dflags hsc_env)                                                putNameLiterally     if | old_hash == new_hash@@ -1451,7 +1416,7 @@ -- | Check the HPC flags haven't changed checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired checkHpcHash hsc_env iface = do-    let old_hash = mi_hpc_hash iface+    let old_hash = mi_hpc_hash (mi_final_exts iface)     new_hash <- liftIO $ fingerprintHpcFlags (hsc_dflags hsc_env)                                                putNameLiterally     if | old_hash == new_hash@@ -1486,11 +1451,30 @@ --   - a new home module has been added that shadows a package module -- See bug #1372. --+-- In addition, we also check if the union of dependencies of the imported+-- modules has any difference to the previous set of dependencies. We would need+-- to recompile in that case also since the `mi_deps` field of ModIface needs+-- to be updated to match that information. This is one of the invariants+-- of interface files (see https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#interface-file-invariants).+-- See bug #16511.+-- -- Returns (RecompBecause <textual reason>) if recompilation is required. checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired checkDependencies hsc_env summary iface- = checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))-  where+ = do+   checkList $+     [ checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))+     , do+         (recomp, mnames_seen) <- runUntilRecompRequired $ map+           checkForNewHomeDependency+           (ms_home_imps summary)+         case recomp of+           UpToDate -> do+             let+               seen_home_deps = Set.unions $ map Set.fromList mnames_seen+             checkIfAllOldHomeDependenciesAreSeen seen_home_deps+           _ -> return recomp]+ where    prev_dep_mods = dep_mods (mi_deps iface)    prev_dep_plgn = dep_plgins (mi_deps iface)    prev_dep_pkgs = dep_pkgs (mi_deps iface)@@ -1522,12 +1506,74 @@            where pkg = moduleUnitId mod         _otherwise  -> return (RecompBecause reason) +   old_deps = Set.fromList $ map fst $ filter (not . snd) prev_dep_mods+   isOldHomeDeps = flip Set.member old_deps+   checkForNewHomeDependency (L _ mname) = do+     let+       mod = mkModule this_pkg mname+       str_mname = moduleNameString mname+       reason = str_mname ++ " changed"+     -- We only want to look at home modules to check if any new home dependency+     -- pops in and thus here, skip modules that are not home. Checking+     -- membership in old home dependencies suffice because the `dep_missing`+     -- check already verified that all imported home modules are present there.+     if not (isOldHomeDeps mname)+       then return (UpToDate, [])+       else do+         mb_result <- getFromModIface "need mi_deps for" mod $ \imported_iface -> do+           let mnames = mname:(map fst $ filter (not . snd) $+                 dep_mods $ mi_deps imported_iface)+           case find (not . isOldHomeDeps) mnames of+             Nothing -> return (UpToDate, mnames)+             Just new_dep_mname -> do+               traceHiDiffs $+                 text "imported home module " <> quotes (ppr mod) <>+                 text " has a new dependency " <> quotes (ppr new_dep_mname)+               return (RecompBecause reason, [])+         return $ fromMaybe (MustCompile, []) mb_result++   -- Performs all recompilation checks in the list until a check that yields+   -- recompile required is encountered. Returns the list of the results of+   -- all UpToDate checks.+   runUntilRecompRequired []             = return (UpToDate, [])+   runUntilRecompRequired (check:checks) = do+     (recompile, value) <- check+     if recompileRequired recompile+       then return (recompile, [])+       else do+         (recomp, values) <- runUntilRecompRequired checks+         return (recomp, value:values)++   checkIfAllOldHomeDependenciesAreSeen seen_deps = do+     let unseen_old_deps = Set.difference+          old_deps+          seen_deps+     if not (null unseen_old_deps)+       then do+         let missing_dep = Set.elemAt 0 unseen_old_deps+         traceHiDiffs $+           text "missing old home dependency " <> quotes (ppr missing_dep)+         return $ RecompBecause "missing old dependency"+       else return UpToDate+ needInterface :: Module -> (ModIface -> IfG RecompileRequired)-              -> IfG RecompileRequired+             -> IfG RecompileRequired needInterface mod continue+  = do+      mb_recomp <- getFromModIface+        "need version info for"+        mod+        continue+      case mb_recomp of+        Nothing -> return MustCompile+        Just recomp -> return recomp++getFromModIface :: String -> Module -> (ModIface -> IfG a)+              -> IfG (Maybe a)+getFromModIface doc_msg mod getter   = do  -- Load the imported interface if possible-    let doc_str = sep [text "need version info for", ppr mod]-    traceHiDiffs (text "Checking usages for module" <+> ppr mod)+    let doc_str = sep [text doc_msg, ppr mod]+    traceHiDiffs (text "Checking innterface for module" <+> ppr mod)      mb_iface <- loadInterface doc_str mod ImportBySystem         -- Load the interface, but don't complain on failure;@@ -1537,12 +1583,12 @@       Failed _ -> do         traceHiDiffs (sep [text "Couldn't load interface for module",                            ppr mod])-        return MustCompile+        return Nothing                   -- Couldn't find or parse a module mentioned in the                   -- old interface file.  Don't complain: it might                   -- just be that the current module doesn't need that                   -- import and it's been deleted-      Succeeded iface -> continue iface+      Succeeded iface -> Just <$> getter iface  -- | Given the usage information extracted from the old -- M.hi file for the module being compiled, figure out@@ -1553,7 +1599,7 @@                                 usg_mod_hash = old_mod_hash }   = needInterface mod $ \iface -> do     let reason = moduleNameString (moduleName mod) ++ " changed"-    checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface)+    checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface))         -- We only track the ABI hash of package modules, rather than         -- individual entity usages, so if the ABI hash changes we must         -- recompile.  This is safe but may entail more recompilation when@@ -1562,7 +1608,7 @@ checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash }   = needInterface mod $ \iface -> do     let reason = moduleNameString (moduleName mod) ++ " changed (raw)"-    checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface)+    checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface))  checkModUsage this_pkg UsageHomeModule{                                 usg_mod_name = mod_name,@@ -1574,9 +1620,9 @@     needInterface mod $ \iface -> do      let-        new_mod_hash    = mi_mod_hash    iface-        new_decl_hash   = mi_hash_fn     iface-        new_export_hash = mi_exp_hash    iface+        new_mod_hash    = mi_mod_hash (mi_final_exts iface)+        new_decl_hash   = mi_hash_fn  (mi_final_exts iface)+        new_export_hash = mi_exp_hash (mi_final_exts iface)          reason = moduleNameString mod_name ++ " changed" @@ -1722,33 +1768,30 @@  where    branch_list = fromBranches branches --- 2nd parameter is the list of branch LHSs, for conversion from incompatible branches--- to incompatible indices+-- 2nd parameter is the list of branch LHSs, in case of a closed type family,+-- for conversion from incompatible branches to incompatible indices.+-- For an open type family the list should be empty. -- See Note [Storing compatibility] in CoAxiom coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch coAxBranchToIfaceBranch tc lhs_s-                        branch@(CoAxBranch { cab_incomps = incomps })-  = (coAxBranchToIfaceBranch' tc branch) { ifaxbIncomps = iface_incomps }+                        (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs+                                    , cab_eta_tvs = eta_tvs+                                    , cab_lhs = lhs, cab_roles = roles+                                    , cab_rhs = rhs, cab_incomps = incomps })++  = IfaceAxBranch { ifaxbTyVars  = toIfaceTvBndrs tvs+                  , ifaxbCoVars  = map toIfaceIdBndr cvs+                  , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs+                  , ifaxbLHS     = toIfaceTcArgs tc lhs+                  , ifaxbRoles   = roles+                  , ifaxbRHS     = toIfaceType rhs+                  , ifaxbIncomps = iface_incomps }   where     iface_incomps = map (expectJust "iface_incomps"-                        . (flip findIndex lhs_s-                          . eqTypes)+                        . flip findIndex lhs_s+                        . eqTypes                         . coAxBranchLHS) incomps --- use this one for standalone branches without incompatibles-coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch-coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs-                                        , cab_eta_tvs = eta_tvs-                                        , cab_lhs = lhs-                                        , cab_roles = roles, cab_rhs = rhs })-  = IfaceAxBranch { ifaxbTyVars    = toIfaceTvBndrs tvs-                  , ifaxbCoVars    = map toIfaceIdBndr cvs-                  , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs-                  , ifaxbLHS       = toIfaceTcArgs tc lhs-                  , ifaxbRoles     = roles-                  , ifaxbRHS       = toIfaceType rhs-                  , ifaxbIncomps   = [] }- ----------------- tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl) -- We *do* tidy TyCons, because they are not (and cannot@@ -1829,7 +1872,8 @@     to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))       = IfaceClosedSynFamilyTyCon (Just (axn, ibr))       where defs = fromBranches $ coAxiomBranches ax-            ibr  = map (coAxBranchToIfaceBranch' tycon) defs+            lhss = map coAxBranchLHS defs+            ibr  = map (coAxBranchToIfaceBranch tycon lhss) defs             axn  = coAxiomName ax      ifaceConDecls (NewTyCon { data_con = con })    = IfNewTyCon  (ifaceConDecl con)
compiler/iface/TcIface.hs view
@@ -16,11 +16,11 @@         typecheckIfaceForInstantiate,         tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,         tcIfaceAnnotations, tcIfaceCompleteSigs,-        tcIfaceExpr,    -- Desired by HERMIT (Trac #7683)+        tcIfaceExpr,    -- Desired by HERMIT (#7683)         tcIfaceGlobal  ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -35,6 +35,7 @@ import Coercion import CoAxiom import TyCoRep    -- needs to build types & coercions in a knot+import TyCoSubst ( substTyCoVars ) import HscTypes import Annotations import InstEnv@@ -757,7 +758,7 @@         --     class C (T a) => D a where         --       data T a         -- Here the associated type T is knot-tied with the class, and-        -- so we must not pull on T too eagerly.  See Trac #5970+        -- so we must not pull on T too eagerly.  See #5970     tc_sig :: IfaceClassOp -> IfL TcMethInfo    tc_sig (IfaceClassOp op_name rdr_ty dm)@@ -789,7 +790,7 @@                                      ; return (Just (tc_def, noSrcSpan)) }                   -- Must be done lazily in case the RHS of the defaults mention                   -- the type constructor being defined here-                  -- e.g.   type AT a; type AT b = AT [b]   Trac #8002+                  -- e.g.   type AT a; type AT b = AT [b]   #8002           return (ATI tc mb_def)     mk_sc_doc pred = text "Superclass" <+> ppr pred@@ -804,7 +805,7 @@        -- a hs-boot declared type constructor that is going to be        -- defined by this module.        -- e.g. type instance F Int = ToBeDefined-       -- See Trac #13803+       -- See #13803        ; tc_branches <- forkM (text "Axiom branches" <+> ppr tc_name)                       $ tc_ax_branches branches        ; let axiom = CoAxiom { co_ax_unique   = nameUnique tc_name@@ -992,7 +993,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~ Notice that we eagerly grab the *kind* from the interface file, but build a forkM thunk for the *rhs* (and family stuff).  To see why,-consider this (Trac #2412)+consider this (#2412)  M.hs:       module M where { import X; data T = MkT S } X.hs:       module X where { import {-# SOURCE #-} M; type S = T }@@ -1140,12 +1141,11 @@ tcIfaceType :: IfaceType -> IfL Type tcIfaceType = go   where-    go (IfaceTyVar n)         = TyVarTy <$> tcIfaceTyVar n-    go (IfaceFreeTyVar n)     = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n)-    go (IfaceLitTy l)         = LitTy <$> tcIfaceTyLit l-    go (IfaceFunTy t1 t2)     = FunTy <$> go t1 <*> go t2-    go (IfaceDFunTy t1 t2)    = FunTy <$> go t1 <*> go t2-    go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks+    go (IfaceTyVar n)          = TyVarTy <$> tcIfaceTyVar n+    go (IfaceFreeTyVar n)      = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n)+    go (IfaceLitTy l)          = LitTy <$> tcIfaceTyLit l+    go (IfaceFunTy flag t1 t2) = FunTy flag <$> go t1 <*> go t2+    go (IfaceTupleTy s i tks)  = tcIfaceTupleTy s i tks     go (IfaceAppTy t ts)       = do { t'  <- go t            ; ts' <- traverse go (appArgsIfaceTypes ts)@@ -1631,7 +1631,7 @@ -- -- There is also a wiki page on the subject, see: -----      https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TyingTheKnot+--      https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/tying-the-knot  -- Note [Knot-tying fallback on boot] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/llvmGen/Llvm/PpLlvm.hs view
@@ -23,7 +23,7 @@      ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude
compiler/llvmGen/Llvm/Types.hs view
@@ -6,7 +6,7 @@  module Llvm.Types where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -185,6 +185,7 @@ pprSpecialStatic (LMBitc v t) =     ppr (pLower t) <> text ", bitcast (" <> ppr v <> text " to " <> ppr t         <> char ')'+pprSpecialStatic v@(LMStaticPointer x) = ppr (pLower $ getVarType x) <> comma <+> ppr v pprSpecialStatic stat = ppr stat  @@ -231,7 +232,7 @@                                    error $ "Can't print this float literal!" ++ showSDoc dflags (ppr f)) ppLit (LMVectorLit ls  )       = char '<' <+> ppCommaJoin ls <+> char '>' ppLit (LMNullLit _     )       = text "null"--- Trac 11487 was an issue where we passed undef for some arguments+-- #11487 was an issue where we passed undef for some arguments -- that were actually live. By chance the registers holding those -- arguments usually happened to have the right values anyways, but -- that was not guaranteed. To find such bugs reliably, we set the@@ -842,8 +843,10 @@                      [x,y] -> [x,y]                      _     -> error "dToStr: too many hex digits for float" -        str  = map toUpper $ concat $ fixEndian $ map hex bs-    in  text "0x" <> text str+    in sdocWithDynFlags (\dflags ->+         let fixEndian = if wORDS_BIGENDIAN dflags then id else reverse+             str       = map toUpper $ concat $ fixEndian $ map hex bs+         in text "0x" <> text str)  -- Note [LLVM Float Types] -- ~~~~~~~~~~~~~~~~~~~~~~~@@ -872,14 +875,6 @@  ppFloat :: Float -> SDoc ppFloat = ppDouble . widenFp---- | Reverse or leave byte data alone to fix endianness on this target.-fixEndian :: [a] -> [a]-#if defined(WORDS_BIGENDIAN)-fixEndian = id-#else-fixEndian = reverse-#endif   --------------------------------------------------------------------------------
compiler/llvmGen/LlvmCodeGen.hs view
@@ -5,7 +5,7 @@ -- module LlvmCodeGen ( LlvmVersion, llvmVersionList, llvmCodeGen, llvmFixupAsm ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -17,20 +17,17 @@ import LlvmCodeGen.Regs import LlvmMangler -import BlockId-import CgUtils ( fixStgRegisters )+import GHC.StgToCmm.CgUtils ( fixStgRegisters ) import Cmm-import CmmUtils-import Hoopl.Block import Hoopl.Collections import PprCmm  import BufWrite import DynFlags+import GHC.Platform ( platformArch, Arch(..) ) import ErrUtils import FastString import Outputable-import UniqSupply import SysTools ( figureLlvmVersion ) import qualified Stream @@ -41,11 +38,11 @@ -- ----------------------------------------------------------------------------- -- | Top-level of the LLVM Code generator ---llvmCodeGen :: DynFlags -> Handle -> UniqSupply-               -> Stream.Stream IO RawCmmGroup ()-               -> IO ()-llvmCodeGen dflags h us cmm_stream-  = withTiming (pure dflags) (text "LLVM CodeGen") (const ()) $ do+llvmCodeGen :: DynFlags -> Handle+               -> Stream.Stream IO RawCmmGroup a+               -> IO a+llvmCodeGen dflags h cmm_stream+  = withTiming dflags (text "LLVM CodeGen") (const ()) $ do        bufh <- newBufHandle h         -- Pass header@@ -64,14 +61,21 @@            "Currently only " <> text (llvmVersionStr supportedLlvmVersion) <> " is supported." <+>            "System LLVM version: " <> text (llvmVersionStr ver) $$            "We will try though..."+         let isS390X = platformArch (targetPlatform dflags) == ArchS390X+         let major_ver = head . llvmVersionList $ ver+         when (isS390X && major_ver < 10 && doWarn) $ putMsg dflags $+           "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+>+           "You are using LLVM version: " <> text (llvmVersionStr ver)         -- run code generation-       runLlvm dflags (fromMaybe supportedLlvmVersion mb_ver) bufh us $+       a <- runLlvm dflags (fromMaybe supportedLlvmVersion mb_ver) bufh $          llvmCodeGen' (liftStream cmm_stream)         bFlush bufh -llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup () -> LlvmM ()+       return a++llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup a -> LlvmM a llvmCodeGen' cmm_stream   = do  -- Preamble         renderLlvm header@@ -79,24 +83,31 @@         cmmMetaLlvmPrelude          -- Procedures-        let llvmStream = Stream.mapM llvmGroupLlvmGens cmm_stream-        _ <- Stream.collect llvmStream+        a <- Stream.consume cmm_stream llvmGroupLlvmGens          -- Declare aliases for forward references         renderLlvm . pprLlvmData =<< generateExternDecls          -- Postamble         cmmUsedLlvmGens++        return a   where     header :: SDoc     header = sdocWithDynFlags $ \dflags ->-      let target = LLVM_TARGET-          layout = case lookup target (llvmTargets dflags) of-            Just (LlvmTarget dl _ _) -> dl-            Nothing -> error $ "Failed to lookup the datalayout for " ++ target ++ "; available targets: " ++ show (map fst $ llvmTargets dflags)-      in     text ("target datalayout = \"" ++ layout ++ "\"")+      let target = platformMisc_llvmTarget $ platformMisc dflags+      in     text ("target datalayout = \"" ++ getDataLayout dflags target ++ "\"")          $+$ text ("target triple = \"" ++ target ++ "\"") +    getDataLayout :: DynFlags -> String -> String+    getDataLayout dflags target =+      case lookup target (llvmTargets $ llvmConfig dflags) of+        Just (LlvmTarget {lDataLayout=dl}) -> dl+        Nothing -> pprPanic "Failed to lookup LLVM data layout" $+                   text "Target:" <+> text target $$+                   hang (text "Available targets:") 4+                        (vcat $ map (text . fst) $ llvmTargets $ llvmConfig dflags)+ llvmGroupLlvmGens :: RawCmmGroup -> LlvmM () llvmGroupLlvmGens cmm = do @@ -135,44 +146,13 @@         renderLlvm $ pprLlvmData (concat gss', concat tss) --- | LLVM can't handle entry blocks which loop back to themselves (could be--- seen as an LLVM bug) so we rearrange the code to keep the original entry--- label which branches to a newly generated second label that branches back--- to itself. See: Trac #11649-fixBottom :: RawCmmDecl -> LlvmM RawCmmDecl-fixBottom cp@(CmmProc hdr entry_lbl live g) =-    maybe (pure cp) fix_block $ mapLookup (g_entry g) blk_map-  where-    blk_map = toBlockMap g--    fix_block :: CmmBlock -> LlvmM RawCmmDecl-    fix_block blk-        | (CmmEntry e_lbl tickscp, middle, CmmBranch b_lbl) <- blockSplit blk-        , isEmptyBlock middle-        , e_lbl == b_lbl = do-            new_lbl <- mkBlockId <$> getUniqueM--            let fst_blk =-                    BlockCC (CmmEntry e_lbl tickscp) BNil (CmmBranch new_lbl)-                snd_blk =-                    BlockCC (CmmEntry new_lbl tickscp) BNil (CmmBranch new_lbl)--            pure . CmmProc hdr entry_lbl live . ofBlockMap (g_entry g)-                $ mapFromList [(e_lbl, fst_blk), (new_lbl, snd_blk)]--    fix_block _ = pure cp--fixBottom rcd = pure rcd- -- | Complete LLVM code generation phase for a single top-level chunk of Cmm. cmmLlvmGen ::RawCmmDecl -> LlvmM () cmmLlvmGen cmm@CmmProc{} = do      -- rewrite assignments to global regs     dflags <- getDynFlag id-    fixed_cmm <- fixBottom $-                    {-# SCC "llvm_fix_regs" #-}-                    fixStgRegisters dflags cmm+    let fixed_cmm = {-# SCC "llvm_fix_regs" #-} fixStgRegisters dflags cmm      dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm])
compiler/llvmGen/LlvmCodeGen/Base.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}  -- ---------------------------------------------------------------------------- -- | Base LLVM Code Generation module@@ -32,10 +33,10 @@         strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,         getGlobalPtr, generateExternDecls, -        aliasify,+        aliasify, llvmDefLabel     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h" #include "ghcautoconf.h"  import GhcPrelude@@ -44,12 +45,12 @@ import LlvmCodeGen.Regs  import CLabel-import CodeGen.Platform ( activeStgRegs )+import GHC.Platform.Regs ( activeStgRegs ) import DynFlags import FastString import Cmm              hiding ( succ ) import Outputable as Outp-import Platform+import GHC.Platform import UniqFM import Unique import BufWrite   ( BufHandle )@@ -58,6 +59,7 @@ import ErrUtils import qualified Stream +import Data.Maybe (fromJust) import Control.Monad (ap) import Data.Char (isDigit) import Data.List (intercalate)@@ -101,7 +103,6 @@ widthToLlvmFloat :: Width -> LlvmType widthToLlvmFloat W32  = LMFloat widthToLlvmFloat W64  = LMDouble-widthToLlvmFloat W80  = LMFloat80 widthToLlvmFloat W128 = LMFloat128 widthToLlvmFloat w    = panic $ "widthToLlvmFloat: Bad float size: " ++ show w @@ -217,7 +218,7 @@   { envVersion :: LlvmVersion      -- ^ LLVM version   , envDynFlags :: DynFlags        -- ^ Dynamic flags   , envOutput :: BufHandle         -- ^ Output buffer-  , envUniq :: UniqSupply          -- ^ Supply of unique values+  , envMask :: !Char               -- ^ Mask for creating unique values   , envFreshMeta :: MetaId         -- ^ Supply of fresh metadata IDs   , envUniqMeta :: UniqFM MetaId   -- ^ Global metadata nodes   , envFunMap :: LlvmEnvMap        -- ^ Global functions so far, with type@@ -233,10 +234,7 @@  -- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }--instance Functor LlvmM where-    fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env-                                  return (f x, env')+    deriving (Functor)  instance Applicative LlvmM where     pure x = LlvmM $ \env -> return (x, env)@@ -251,16 +249,12 @@  instance MonadUnique LlvmM where     getUniqueSupplyM = do-        us <- getEnv envUniq-        let (us1, us2) = splitUniqSupply us-        modifyEnv (\s -> s { envUniq = us2 })-        return us1+        mask <- getEnv envMask+        liftIO $! mkSplitUniqSupply mask      getUniqueM = do-        us <- getEnv envUniq-        let (u,us') = takeUniqFromSupply us-        modifyEnv (\s -> s { envUniq = us' })-        return u+        mask <- getEnv envMask+        liftIO $! uniqFromMask mask  -- | Lifting of IO actions. Not exported, as we want to encapsulate IO. liftIO :: IO a -> LlvmM a@@ -268,10 +262,10 @@                               return (x, env)  -- | Get initial Llvm environment.-runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM () -> IO ()-runLlvm dflags ver out us m = do-    _ <- runLlvmM m env-    return ()+runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a+runLlvm dflags ver out m = do+    (a, _) <- runLlvmM m env+    return a   where env = LlvmEnv { envFunMap = emptyUFM                       , envVarMap = emptyUFM                       , envStackRegs = []@@ -280,7 +274,7 @@                       , envVersion = ver                       , envDynFlags = dflags                       , envOutput = out-                      , envUniq = us+                      , envMask = 'n'                       , envFreshMeta = MetaId 0                       , envUniqMeta = emptyUFM                       }@@ -401,7 +395,7 @@     mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr]   where     mk n ret args = do-      let n' = fsLit n `appendFS` fsLit "$def"+      let n' = llvmDefLabel $ fsLit n           decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret                                  FixedArgs (tysToParams args) Nothing       renderLlvm $ ppLlvmFunctionDecl decl@@ -414,17 +408,15 @@ -- | Pretty print a 'CLabel'. strCLabel_llvm :: CLabel -> LlvmM LMString strCLabel_llvm lbl = do-    platform <- getLlvmPlatform     dflags <- getDynFlags-    let sdoc = pprCLabel platform lbl+    let sdoc = pprCLabel dflags lbl         str = Outp.renderWithStyle dflags sdoc (Outp.mkCodeStyle Outp.CStyle)     return (fsLit str)  strDisplayName_llvm :: CLabel -> LlvmM LMString strDisplayName_llvm lbl = do-    platform <- getLlvmPlatform     dflags <- getDynFlags-    let sdoc = pprCLabel platform lbl+    let sdoc = pprCLabel dflags lbl         depth = Outp.PartWay 1         style = Outp.mkUserStyle dflags Outp.reallyAlwaysQualify depth         str = Outp.renderWithStyle dflags sdoc style@@ -440,9 +432,8 @@  strProcedureName_llvm :: CLabel -> LlvmM LMString strProcedureName_llvm lbl = do-    platform <- getLlvmPlatform     dflags <- getDynFlags-    let sdoc = pprCLabel platform lbl+    let sdoc = pprCLabel dflags lbl         depth = Outp.PartWay 1         style = Outp.mkUserStyle dflags Outp.neverQualify depth         str = Outp.renderWithStyle dflags sdoc style@@ -461,12 +452,17 @@   let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing   case m_ty of     -- Directly reference if we have seen it already-    Just ty -> return $ mkGlbVar (llvmLbl `appendFS` fsLit "$def") ty Global+    Just ty -> return $ mkGlbVar (llvmDefLabel llvmLbl) ty Global     -- Otherwise use a forward alias of it     Nothing -> do       saveAlias llvmLbl       return $ mkGlbVar llvmLbl i8 Alias +-- | Derive the definition label. It has an identified+-- structure type.+llvmDefLabel :: LMString -> LMString+llvmDefLabel = (`appendFS` fsLit "$def")+ -- | Generate definitions for aliases forward-referenced by @getGlobalPtr@. -- -- Must be called at a point where we are sure that no new global definitions@@ -497,10 +493,28 @@ -- | Here we take a global variable definition, rename it with a -- @$def@ suffix, and generate the appropriate alias. aliasify :: LMGlobal -> LlvmM [LMGlobal]+-- See note [emit-time elimination of static indirections] in CLabel.+-- Here we obtain the indirectee's precise type and introduce+-- fresh aliases to both the precise typed label (lbl$def) and the i8*+-- typed (regular) label of it with the matching new names.+aliasify (LMGlobal (LMGlobalVar lbl ty@LMAlias{} link sect align Alias)+                   (Just orig)) = do+    let defLbl = llvmDefLabel lbl+        LMStaticPointer (LMGlobalVar origLbl _ oLnk Nothing Nothing Alias) = orig+        defOrigLbl = llvmDefLabel origLbl+        orig' = LMStaticPointer (LMGlobalVar origLbl i8Ptr oLnk Nothing Nothing Alias)+    origType <- funLookup origLbl+    let defOrig = LMBitc (LMStaticPointer (LMGlobalVar defOrigLbl+                                           (pLift $ fromJust origType) oLnk+                                           Nothing Nothing Alias))+                         (pLift ty)+    pure [ LMGlobal (LMGlobalVar defLbl ty link sect align Alias) (Just defOrig)+         , LMGlobal (LMGlobalVar lbl i8Ptr link sect align Alias) (Just orig')+         ] aliasify (LMGlobal var val) = do     let LMGlobalVar lbl ty link sect align const = var -        defLbl = lbl `appendFS` fsLit "$def"+        defLbl = llvmDefLabel lbl         defVar = LMGlobalVar defLbl ty Internal sect align const          defPtrVar = LMGlobalVar defLbl (LMPointer ty) link Nothing Nothing const
compiler/llvmGen/LlvmCodeGen/CodeGen.hs view
@@ -5,7 +5,7 @@ -- module LlvmCodeGen.CodeGen ( genLlvmProc ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -14,7 +14,7 @@ import LlvmCodeGen.Regs  import BlockId-import CodeGen.Platform ( activeStgRegs, callerSaves )+import GHC.Platform.Regs ( activeStgRegs, callerSaves ) import CLabel import Cmm import PprCmm@@ -29,7 +29,7 @@ import ForeignCall import Outputable hiding (panic, pprPanic) import qualified Outputable-import Platform+import GHC.Platform import OrdList import UniqSupply import Unique@@ -66,20 +66,24 @@  -- | Generate code for a list of blocks that make up a complete -- procedure. The first block in the list is expected to be the entry--- point and will get the prologue.+-- point. basicBlocksCodeGen :: LiveGlobalRegs -> [CmmBlock]                       -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl]) basicBlocksCodeGen _    []                     = panic "no entry block!"-basicBlocksCodeGen live (entryBlock:cmmBlocks)-  = do (prologue, prologueTops) <- funPrologue live (entryBlock:cmmBlocks)+basicBlocksCodeGen live cmmBlocks+  = do -- Emit the prologue+       -- N.B. this must be its own block to ensure that the entry block of the+       -- procedure has no predecessors, as required by the LLVM IR. See #17589+       -- and #11649.+       bid <- newBlockId+       (prologue, prologueTops) <- funPrologue live cmmBlocks+       let entryBlock = BasicBlock bid (fromOL prologue)         -- Generate code-       (BasicBlock bid entry, entryTops) <- basicBlockCodeGen entryBlock        (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks         -- Compose-       let entryBlock = BasicBlock bid (fromOL prologue ++ entry)-       return (entryBlock : blocks, prologueTops ++ entryTops ++ concat topss)+       return (entryBlock : blocks, prologueTops ++ concat topss)   -- | Generate code for one block@@ -238,6 +242,8 @@     genCallSimpleCast w t dsts args genCall t@(PrimTarget (MO_BSwap w)) dsts args =     genCallSimpleCast w t dsts args+genCall t@(PrimTarget (MO_BRev w)) dsts args =+    genCallSimpleCast w t dsts args  genCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = runStmtsDecls $ do     addrVar <- exprToVarW addr@@ -751,7 +757,9 @@    return $ case mop of     MO_F32_Exp    -> fsLit "expf"+    MO_F32_ExpM1  -> fsLit "expm1f"     MO_F32_Log    -> fsLit "logf"+    MO_F32_Log1P  -> fsLit "log1pf"     MO_F32_Sqrt   -> fsLit "llvm.sqrt.f32"     MO_F32_Fabs   -> fsLit "llvm.fabs.f32"     MO_F32_Pwr    -> fsLit "llvm.pow.f32"@@ -773,7 +781,9 @@     MO_F32_Atanh  -> fsLit "atanhf"      MO_F64_Exp    -> fsLit "exp"+    MO_F64_ExpM1  -> fsLit "expm1"     MO_F64_Log    -> fsLit "log"+    MO_F64_Log1P  -> fsLit "log1p"     MO_F64_Sqrt   -> fsLit "llvm.sqrt.f64"     MO_F64_Fabs   -> fsLit "llvm.fabs.f64"     MO_F64_Pwr    -> fsLit "llvm.pow.f64"@@ -799,10 +809,11 @@     MO_Memset _   -> fsLit $ "llvm.memset."  ++ intrinTy2     MO_Memcmp _   -> fsLit $ "memcmp" -    (MO_PopCnt w) -> fsLit $ "llvm.ctpop."  ++ showSDoc dflags (ppr $ widthToLlvmInt w)-    (MO_BSwap w)  -> fsLit $ "llvm.bswap."  ++ showSDoc dflags (ppr $ widthToLlvmInt w)-    (MO_Clz w)    -> fsLit $ "llvm.ctlz."   ++ showSDoc dflags (ppr $ widthToLlvmInt w)-    (MO_Ctz w)    -> fsLit $ "llvm.cttz."   ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    (MO_PopCnt w) -> fsLit $ "llvm.ctpop."      ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    (MO_BSwap w)  -> fsLit $ "llvm.bswap."      ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    (MO_BRev w)   -> fsLit $ "llvm.bitreverse." ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    (MO_Clz w)    -> fsLit $ "llvm.ctlz."       ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    (MO_Ctz w)    -> fsLit $ "llvm.cttz."       ++ showSDoc dflags (ppr $ widthToLlvmInt w)      (MO_Pdep w)   ->  let w' = showSDoc dflags (ppr $ widthInBits w)                       in  if isBmi2Enabled dflags@@ -1826,7 +1837,10 @@         markStackReg r         return $ toOL [alloc, Store rval reg] -  return (concatOL stmtss, [])+  return (concatOL stmtss `snocOL` jumpToEntry, [])+  where+    entryBlk : _ = cmmBlocks+    jumpToEntry = Branch $ blockIdToLlvm (entryLabel entryBlk)  -- | Function epilogue. Load STG variables to use as argument for call. -- STG Liveness optimisation done here.
compiler/llvmGen/LlvmCodeGen/Data.hs view
@@ -7,7 +7,7 @@         genLlvmData, genData     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -18,10 +18,11 @@ import CLabel import Cmm import DynFlags-import Platform+import GHC.Platform  import FastString import Outputable+import qualified Data.ByteString as BS  -- ---------------------------------------------------------------------------- -- * Constants@@ -31,26 +32,56 @@ structStr :: LMString structStr = fsLit "_struct" +-- | The LLVM visibility of the label+linkage :: CLabel -> LlvmLinkageType+linkage lbl = if externallyVisibleCLabel lbl+              then ExternallyVisible else Internal+ -- ---------------------------------------------------------------------------- -- * Top level --  -- | Pass a CmmStatic section to an equivalent Llvm code. genLlvmData :: (Section, CmmStatics) -> LlvmM LlvmData+-- See note [emit-time elimination of static indirections] in CLabel.+genLlvmData (_, Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])+  | lbl == mkIndStaticInfoLabel+  , let labelInd (CmmLabelOff l _) = Just l+        labelInd (CmmLabel l) = Just l+        labelInd _ = Nothing+  , Just ind' <- labelInd ind+  , alias `mayRedirectTo` ind' = do+    label <- strCLabel_llvm alias+    label' <- strCLabel_llvm ind'+    let link     = linkage alias+        link'    = linkage ind'+        -- the LLVM type we give the alias is an empty struct type+        -- but it doesn't really matter, as the pointer is only+        -- used for (bit/int)casting.+        tyAlias  = LMAlias (label `appendFS` structStr, LMStructU [])++        aliasDef = LMGlobalVar label tyAlias link Nothing Nothing Alias+        -- we don't know the type of the indirectee here+        indType  = panic "will be filled by 'aliasify', later"+        orig     = LMStaticPointer $ LMGlobalVar label' indType link' Nothing Nothing Alias++    pure ([LMGlobal aliasDef $ Just orig], [tyAlias])+ genLlvmData (sec, Statics lbl xs) = do     label <- strCLabel_llvm lbl     static <- mapM genData xs     lmsec <- llvmSection sec+    platform <- getLlvmPlatform     let types   = map getStatType static          strucTy = LMStruct types-        tyAlias = LMAlias ((label `appendFS` structStr), strucTy)+        tyAlias = LMAlias (label `appendFS` structStr, strucTy)          struct         = Just $ LMStaticStruc static tyAlias-        link           = if (externallyVisibleCLabel lbl)-                            then ExternallyVisible else Internal+        link           = linkage lbl         align          = case sec of-                            Section CString _ -> Just 1+                            Section CString _ -> if (platformArch platform == ArchS390X)+                                                    then Just 2 else Just 1                             _                 -> Nothing         const          = if isSecConstant sec then Constant else Global         varDef         = LMGlobalVar label tyAlias link lmsec align const@@ -102,7 +133,8 @@ genData :: CmmStatic -> LlvmM LlvmStatic  genData (CmmString str) = do-    let v  = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8) str+    let v  = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8)+                 (BS.unpack str)         ve = v ++ [LMStaticLit $ LMIntLit 0 i8]     return $ LMStaticArray ve (LMArray (length ve) i8)
compiler/llvmGen/LlvmCodeGen/Ppr.hs view
@@ -7,7 +7,7 @@         pprLlvmCmmDecl, pprLlvmData, infoSection     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -71,7 +71,7 @@        let fun = LlvmFunction funDec funArgs llvmStdFunAttrs funSect                               prefix lmblocks            name = decName $ funcDecl fun-           defName = name `appendFS` fsLit "$def"+           defName = llvmDefLabel name            funcDecl' = (funcDecl fun) { decName = defName }            fun' = fun { funcDecl = funcDecl' }            funTy = LMFunction funcDecl'
compiler/llvmGen/LlvmCodeGen/Regs.hs view
@@ -9,7 +9,7 @@         stgTBAA, baseN, stackN, heapN, rxN, topN, tbaa, getTBAA     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude
compiler/llvmGen/LlvmMangler.hs view
@@ -14,7 +14,7 @@ import GhcPrelude  import DynFlags ( DynFlags, targetPlatform )-import Platform ( platformArch, Arch(..) )+import GHC.Platform ( platformArch, Arch(..) ) import ErrUtils ( withTiming ) import Outputable ( text ) @@ -25,7 +25,7 @@ -- | Read in assembly file and process llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO () llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-}-    withTiming (pure dflags) (text "LLVM Mangler") id $+    withTiming dflags (text "LLVM Mangler") id $     withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do         go r w         hClose r
compiler/main/Ar.hs view
@@ -106,7 +106,7 @@                         return $ C.unpack $ C.takeWhile (/= ' ') name         off2    <- liftM fromIntegral bytesRead :: Get Int         file    <- getByteString (st_size - (off2 - off1))-        -- data sections are two byte aligned (see Trac #15396)+        -- data sections are two byte aligned (see #15396)         when (odd st_size) $           void (getByteString 1) @@ -135,7 +135,7 @@         fail ("[BSD Archive] Invalid archive header end marker for name: " ++               C.unpack name)       file <- getByteString st_size-      -- data sections are two byte aligned (see Trac #15396)+      -- data sections are two byte aligned (see #15396)       when (odd st_size) $         void (getByteString 1)       name <- return . C.unpack $
compiler/main/CodeOutput.hs view
@@ -8,24 +8,23 @@  module CodeOutput( codeOutput, outputForeignStubs ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude -import AsmCodeGen ( nativeCodeGen )-import LlvmCodeGen ( llvmCodeGen )+import AsmCodeGen       ( nativeCodeGen )+import LlvmCodeGen      ( llvmCodeGen )  import UniqSupply       ( mkSplitUniqSupply )  import Finder           ( mkStubPaths )-import PprC             ( writeCs )+import PprC             ( writeC ) import CmmLint          ( cmmLint ) import Packages import Cmm              ( RawCmmGroup ) import HscTypes import DynFlags-import Config-import Stream           (Stream)+import Stream           ( Stream ) import qualified Stream import FileCleanup @@ -55,10 +54,11 @@            -> [(ForeignSrcLang, FilePath)]            -- ^ additional files to be compiled with with the C compiler            -> [InstalledUnitId]-           -> Stream IO RawCmmGroup ()                       -- Compiled C--+           -> Stream IO RawCmmGroup a                       -- Compiled C--            -> IO (FilePath,                   (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),-                  [(ForeignSrcLang, FilePath)]{-foreign_fps-})+                  [(ForeignSrcLang, FilePath)]{-foreign_fps-},+                  a)  codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps   cmm_stream@@ -70,9 +70,10 @@                     then Stream.mapM do_lint cmm_stream                     else cmm_stream -              do_lint cmm = withTiming (pure dflags)-                                       (text "CmmLint"<+>brackets (ppr this_mod))-                                       (const ()) $ do+              do_lint cmm = withTimingSilent+                  dflags+                  (text "CmmLint"<+>brackets (ppr this_mod))+                  (const ()) $ do                 { case cmmLint dflags cmm of                         Just err -> do { log_action dflags                                                    dflags@@ -88,15 +89,14 @@                 }          ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs-        ; case hscTarget dflags of {-             HscAsm         -> outputAsm dflags this_mod location filenm-                                         linted_cmm_stream;-             HscC           -> outputC dflags filenm linted_cmm_stream pkg_deps;-             HscLlvm        -> outputLlvm dflags filenm linted_cmm_stream;-             HscInterpreted -> panic "codeOutput: HscInterpreted";-             HscNothing     -> panic "codeOutput: HscNothing"-          }-        ; return (filenm, stubs_exist, foreign_fps)+        ; a <- case hscTarget dflags of+                 HscAsm         -> outputAsm dflags this_mod location filenm+                                             linted_cmm_stream+                 HscC           -> outputC dflags filenm linted_cmm_stream pkg_deps+                 HscLlvm        -> outputLlvm dflags filenm linted_cmm_stream+                 HscInterpreted -> panic "codeOutput: HscInterpreted"+                 HscNothing     -> panic "codeOutput: HscNothing"+        ; return (filenm, stubs_exist, foreign_fps, a)         }  doOutput :: String -> (Handle -> IO a) -> IO a@@ -112,37 +112,35 @@  outputC :: DynFlags         -> FilePath-        -> Stream IO RawCmmGroup ()+        -> Stream IO RawCmmGroup a         -> [InstalledUnitId]-        -> IO ()+        -> IO a  outputC dflags filenm cmm_stream packages   = do-       -- ToDo: make the C backend consume the C-- incrementally, by-       -- pushing the cmm_stream inside (c.f. nativeCodeGen)-       rawcmms <- Stream.collect cmm_stream+       withTiming dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do -       -- figure out which header files to #include in the generated .hc file:-       ---       --   * extra_includes from packages-       --   * -#include options from the cmdline and OPTIONS pragmas-       --   * the _stub.h file, if there is one.-       ---       let rts = getPackageDetails dflags rtsUnitId+         -- figure out which header files to #include in the generated .hc file:+         --+         --   * extra_includes from packages+         --   * -#include options from the cmdline and OPTIONS pragmas+         --   * the _stub.h file, if there is one.+         --+         let rts = getPackageDetails dflags rtsUnitId -       let cc_injects = unlines (map mk_include (includes rts))-           mk_include h_file =-            case h_file of-               '"':_{-"-} -> "#include "++h_file-               '<':_      -> "#include "++h_file-               _          -> "#include \""++h_file++"\""+         let cc_injects = unlines (map mk_include (includes rts))+             mk_include h_file =+              case h_file of+                 '"':_{-"-} -> "#include "++h_file+                 '<':_      -> "#include "++h_file+                 _          -> "#include \""++h_file++"\"" -       let pkg_names = map installedUnitIdString packages+         let pkg_names = map installedUnitIdString packages -       doOutput filenm $ \ h -> do-          hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")-          hPutStr h cc_injects-          writeCs dflags h rawcmms+         doOutput filenm $ \ h -> do+            hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")+            hPutStr h cc_injects+            Stream.consume cmm_stream (writeC dflags h)  {- ************************************************************************@@ -153,18 +151,17 @@ -}  outputAsm :: DynFlags -> Module -> ModLocation -> FilePath-          -> Stream IO RawCmmGroup ()-          -> IO ()+          -> Stream IO RawCmmGroup a+          -> IO a outputAsm dflags this_mod location filenm cmm_stream- | cGhcWithNativeCodeGen == "YES"+ | platformMisc_ghcWithNativeCodeGen $ platformMisc dflags   = do ncg_uniqs <- mkSplitUniqSupply 'n'         debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm) -       _ <- {-# SCC "OutputAsm" #-} doOutput filenm $+       {-# SCC "OutputAsm" #-} doOutput filenm $            \h -> {-# SCC "NativeCodeGen" #-}                  nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream-       return ()   | otherwise   = panic "This compiler was built without a native code generator"@@ -177,13 +174,11 @@ ************************************************************************ -} -outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO ()+outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a outputLlvm dflags filenm cmm_stream-  = do ncg_uniqs <- mkSplitUniqSupply 'n'--       {-# SCC "llvm_output" #-} doOutput filenm $+  = do {-# SCC "llvm_output" #-} doOutput filenm $            \f -> {-# SCC "llvm_CodeGen" #-}-                 llvmCodeGen dflags f ncg_uniqs cmm_stream+                 llvmCodeGen dflags f cmm_stream  {- ************************************************************************@@ -226,12 +221,13 @@             mk_include i = "#include \"" ++ i ++ "\"\n"              -- wrapper code mentions the ffi_arg type, which comes from ffi.h-            ffi_includes | cLibFFI   = "#include \"ffi.h\"\n"-                         | otherwise = ""+            ffi_includes+              | platformMisc_libFFI $ platformMisc dflags = "#include <ffi.h>\n"+              | otherwise = ""          stub_h_file_exists            <- outputForeignStubs_help stub_h stub_h_output_w-                ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr+                ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr          dumpIfSet_dyn dflags Opt_D_dump_foreign                       "Foreign export stubs" stub_c_output_d@@ -239,7 +235,7 @@         stub_c_file_exists            <- outputForeignStubs_help stub_c stub_c_output_w                 ("#define IN_STG_CODE 0\n" ++-                 "#include \"Rts.h\"\n" +++                 "#include <Rts.h>\n" ++                  rts_includes ++                  ffi_includes ++                  cplusplus_hdr)@@ -252,8 +248,8 @@                                        then Just stub_c                                        else Nothing )  where-   cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"-   cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"+   cplusplus_hdr = "#if defined(__cplusplus)\nextern \"C\" {\n#endif\n"+   cplusplus_ftr = "#if defined(__cplusplus)\n}\n#endif\n"   -- Don't use doOutput for dumping the f. export stubs@@ -264,4 +260,3 @@ outputForeignStubs_help fname doc_str header footer    = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")         return True-
compiler/main/DriverMkDepend.hs view
@@ -12,7 +12,7 @@         doMkDependHS   ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -41,6 +41,7 @@ import System.IO.Error  ( isEOFError ) import Control.Monad    ( when ) import Data.Maybe       ( isJust )+import Data.IORef  ----------------------------------------------------------------- --@@ -85,7 +86,7 @@     -- Print out the dependencies if wanted     liftIO $ debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted) -    -- Prcess them one by one, dumping results into makefile+    -- Process them one by one, dumping results into makefile     -- and complaining about cycles     hsc_env <- getSession     root <- liftIO getCurrentDirectory@@ -223,6 +224,18 @@                 -- Emit std dependency of the object(s) on the source file                 -- Something like       A.o : A.hs         ; writeDependency root hdl obj_files src_file++                -- Emit a dependency for each CPP import+        ; when (depIncludeCppDeps dflags) $ do+            -- CPP deps are descovered in the module parsing phase by parsing+            -- comment lines left by the preprocessor.+            -- Note that GHC.parseModule may throw an exception if the module+            -- fails to parse, which may not be desirable (see #16616).+          { session <- Session <$> newIORef hsc_env+          ; parsedMod <- reflectGhc (GHC.parseModule node) session+          ; mapM_ (writeDependency root hdl obj_files)+                  (GHC.pm_extra_src_files parsedMod)+          }                  -- Emit a dependency for each import
compiler/main/DriverPipeline.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns #-}-{-# OPTIONS_GHC -fno-cse #-}--- -fno-cse is needed for GLOBAL_VAR's to behave properly+{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-}  ----------------------------------------------------------------------------- --@@ -29,10 +27,12 @@    hscPostBackendPhase, getLocation, setModLocation, setDynFlags,    runPhase, exeFileName,    maybeCreateManifest,+   doCpp,    linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode   ) where -#include "GhclibHsVersions.h"+#include <ghcplatform.h>+#include "HsVersions.h"  import GhcPrelude @@ -49,7 +49,6 @@ import Module import ErrUtils import DynFlags-import Config import Panic import Util import StringBuffer     ( hGetStringBuffer, hPutStringBuffer )@@ -58,21 +57,23 @@ import SrcLoc import LlvmCodeGen      ( llvmFixupAsm, llvmVersionList ) import MonadUtils-import Platform+import GHC.Platform import TcRnTypes+import ToolSettings import Hooks import qualified GHC.LanguageExtensions as LangExt import FileCleanup import Ar import Bag              ( unitBag ) import FastString       ( mkFastString )+import MkIface          ( mkFullIface )  import Exception import System.Directory import System.FilePath import System.IO import Control.Monad-import Data.List        ( isInfixOf, isSuffixOf, intercalate )+import Data.List        ( isInfixOf, intercalate ) import Data.Maybe import Data.Version import Data.Either      ( partitionEithers )@@ -97,15 +98,18 @@ preprocess hsc_env input_fn mb_input_buf mb_phase =   handleSourceError (\err -> return (Left (srcErrorMessages err))) $   ghandle handler $-  fmap Right $-  ASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)-  runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase)+  fmap Right $ do+  MASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)+  (dflags, fp, mb_iface) <- runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase)         Nothing         -- We keep the processed file for the whole session to save on         -- duplicated work in ghci.         (Temporary TFL_GhcSession)         Nothing{-no ModLocation-}         []{-no foreign objects-}+  -- We stop before Hsc phase so we shouldn't generate an interface+  MASSERT(isNothing mb_iface)+  return (dflags, fp)   where     srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1     handler (ProgramError msg) = return $ Left $ unitBag $@@ -149,13 +153,14 @@             -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful  compileOne' m_tc_result mHscMessage-            hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable+            hsc_env0 summary mod_index nmods mb_old_iface mb_old_linkable             source_modified0  = do     debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp) -   (status, hmi0) <- hscIncrementalCompile+   -- Run the pipeline up to codeGen (so everything up to, but not including, STG)+   (status, hmi_details, plugin_dflags) <- hscIncrementalCompile                         always_do_basic_recompilation_check                         m_tc_result mHscMessage                         hsc_env summary source_modified mb_old_iface (mod_index, nmods)@@ -168,28 +173,32 @@                addFilesToClean flags TFL_GhcSession $                    [ml_obj_file $ ms_location summary] +   -- Use an HscEnv with DynFlags updated with the plugin info (returned from+   -- hscIncrementalCompile)+   let hsc_env' = hsc_env{ hsc_dflags = plugin_dflags }+    case (status, hsc_lang) of-        (HscUpToDate, _) ->+        (HscUpToDate iface, _) ->             -- TODO recomp014 triggers this assert. What's going on?!-            -- ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) )-            return hmi0 { hm_linkable = maybe_old_linkable }-        (HscNotGeneratingCode, HscNothing) ->+            -- ASSERT( isJust mb_old_linkable || isNoLink (ghcLink dflags) )+            return $! HomeModInfo iface hmi_details mb_old_linkable+        (HscNotGeneratingCode iface, HscNothing) ->             let mb_linkable = if isHsBootOrSig src_flavour                                 then Nothing                                 -- TODO: Questionable.                                 else Just (LM (ms_hs_date summary) this_mod [])-            in return hmi0 { hm_linkable = mb_linkable }-        (HscNotGeneratingCode, _) -> panic "compileOne HscNotGeneratingCode"+            in return $! HomeModInfo iface hmi_details mb_linkable+        (HscNotGeneratingCode _, _) -> panic "compileOne HscNotGeneratingCode"         (_, HscNothing) -> panic "compileOne HscNothing"-        (HscUpdateBoot, HscInterpreted) -> do-            return hmi0-        (HscUpdateBoot, _) -> do+        (HscUpdateBoot iface, HscInterpreted) -> do+            return $! HomeModInfo iface hmi_details Nothing+        (HscUpdateBoot iface, _) -> do             touchObjectFile dflags object_filename-            return hmi0-        (HscUpdateSig, HscInterpreted) ->-            let linkable = LM (ms_hs_date summary) this_mod []-            in return hmi0 { hm_linkable = Just linkable }-        (HscUpdateSig, _) -> do+            return $! HomeModInfo iface hmi_details Nothing+        (HscUpdateSig iface, HscInterpreted) -> do+            let !linkable = LM (ms_hs_date summary) this_mod []+            return $! HomeModInfo iface hmi_details (Just linkable)+        (HscUpdateSig iface, _) -> do             output_fn <- getOutputFilename next_phase                             (Temporary TFL_CurrentModule) basename dflags                             next_phase (Just location)@@ -197,26 +206,34 @@             -- #10660: Use the pipeline instead of calling             -- compileEmptyStub directly, so -dynamic-too gets             -- handled properly-            _ <- runPipeline StopLn hsc_env+            _ <- runPipeline StopLn hsc_env'                               (output_fn,                                Nothing,                                Just (HscOut src_flavour-                                            mod_name HscUpdateSig))+                                            mod_name (HscUpdateSig iface)))                               (Just basename)                               Persistent                               (Just location)                               []             o_time <- getModificationUTCTime object_filename-            let linkable = LM o_time this_mod [DotO object_filename]-            return hmi0 { hm_linkable = Just linkable }-        (HscRecomp cgguts summary, HscInterpreted) -> do-            (hasStub, comp_bc, spt_entries) <--                hscInteractive hsc_env cgguts summary+            let !linkable = LM o_time this_mod [DotO object_filename]+            return $! HomeModInfo iface hmi_details (Just linkable)+        (HscRecomp { hscs_guts = cgguts,+                     hscs_mod_location = mod_location,+                     hscs_partial_iface = partial_iface,+                     hscs_old_iface_hash = mb_old_iface_hash,+                     hscs_iface_dflags = iface_dflags }, HscInterpreted) -> do+            -- In interpreted mode the regular codeGen backend is not run so we+            -- generate a interface without codeGen info.+            final_iface <- mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface+            liftIO $ hscMaybeWriteIface dflags final_iface mb_old_iface_hash mod_location +            (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cgguts mod_location+             stub_o <- case hasStub of                       Nothing -> return []                       Just stub_c -> do-                          stub_o <- compileStub hsc_env stub_c+                          stub_o <- compileStub hsc_env' stub_c                           return [DotO stub_o]              let hs_unlinked = [BCOs comp_bc spt_entries]@@ -227,29 +244,28 @@               -- with the filesystem's clock.  It's just as accurate:               -- if the source is modified, then the linkable will               -- be out of date.-            let linkable = LM unlinked_time (ms_mod summary)+            let !linkable = LM unlinked_time (ms_mod summary)                            (hs_unlinked ++ stub_o)-            return hmi0 { hm_linkable = Just linkable }-        (HscRecomp cgguts summary, _) -> do+            return $! HomeModInfo final_iface hmi_details (Just linkable)+        (HscRecomp{}, _) -> do             output_fn <- getOutputFilename next_phase                             (Temporary TFL_CurrentModule)                             basename dflags next_phase (Just location)             -- We're in --make mode: finish the compilation pipeline.-            _ <- runPipeline StopLn hsc_env+            (_, _, Just iface) <- runPipeline StopLn hsc_env'                               (output_fn,                                Nothing,-                               Just (HscOut src_flavour mod_name (HscRecomp cgguts summary)))+                               Just (HscOut src_flavour mod_name status))                               (Just basename)                               Persistent                               (Just location)                               []                   -- The object filename comes from the ModLocation             o_time <- getModificationUTCTime object_filename-            let linkable = LM o_time this_mod [DotO object_filename]-            return hmi0 { hm_linkable = Just linkable }+            let !linkable = LM o_time this_mod [DotO object_filename]+            return $! HomeModInfo iface hmi_details (Just linkable)   where dflags0     = ms_hspp_opts summary-        this_mod    = ms_mod summary        location    = ms_location summary        input_fn    = expectJust "compile:hs" (ml_hs_file location)@@ -262,7 +278,7 @@         src_flavour = ms_hsc_src summary        mod_name = ms_mod_name summary-       next_phase = hscPostBackendPhase dflags src_flavour hsc_lang+       next_phase = hscPostBackendPhase src_flavour hsc_lang        object_filename = ml_obj_file location         -- #8180 - when using TemplateHaskell, switch on -dynamic-too so@@ -334,7 +350,7 @@               LangObjcxx -> Cobjcxx               LangAsm    -> As True -- allow CPP               RawObject  -> panic "compileForeign: should be unreachable"-        (_, stub_o) <- runPipeline StopLn hsc_env+        (_, stub_o, _) <- runPipeline StopLn hsc_env                        (stub_c, Nothing, Just (RealPhase phase))                        Nothing (Temporary TFL_GhcSession)                        Nothing{-no ModLocation-}@@ -351,7 +367,7 @@   -- valid) stub object file for signatures.  However,   -- we make sure this object file has a unique symbol,   -- so that ranlib on OS X doesn't complain, see-  -- http://ghc.haskell.org/trac/ghc/ticket/12673+  -- https://gitlab.haskell.org/ghc/ghc/issues/12673   -- and https://github.com/haskell/cabal/issues/2257   empty_stub <- newTempName dflags TFL_CurrentModule "c"   let src = text "int" <+> ppr (mkModule (thisPackage dflags) mod_name) <+> text "= 0;"@@ -384,7 +400,7 @@   = lookupHook linkHook l dflags ghcLink dflags   where     l LinkInMemory _ _ _-      = if cGhcWithInterpreter == "YES"+      = if platformMisc_ghcWithInterpreter $ platformMisc dflags         then -- Not Linking...(demand linker will do the job)              return Succeeded         else panicBadLink LinkInMemory@@ -527,7 +543,6 @@     let         dflags    = hsc_dflags hsc_env-        split     = gopt Opt_SplitObjs dflags         mb_o_file = outputFile dflags         ghc_link  = ghcLink dflags      -- Set by -c or -no-link @@ -544,10 +559,7 @@                 -- -o foo applies to the file we are compiling now          | otherwise = Persistent -        stop_phase' = case stop_phase of-                        As _ | split -> SplitAs-                        _            -> stop_phase-   ( _, out_file) <- runPipeline stop_phase' hsc_env+   ( _, out_file, _) <- runPipeline stop_phase hsc_env                             (src, Nothing, fmap RealPhase mb_phase)                             Nothing                             output@@ -590,7 +602,8 @@   -> PipelineOutput             -- ^ Output filename   -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module   -> [FilePath]                 -- ^ foreign objects-  -> IO (DynFlags, FilePath)    -- ^ (final flags, output filename)+  -> IO (DynFlags, FilePath, Maybe ModIface)+                                -- ^ (final flags, output filename, interface) runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase)              mb_basename output maybe_loc foreign_os @@ -684,20 +697,21 @@   -> FilePath                   -- ^ Input filename   -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module   -> [FilePath]                 -- ^ foreign objects, if we have one-  -> IO (DynFlags, FilePath)    -- ^ (final flags, output filename)+  -> IO (DynFlags, FilePath, Maybe ModIface)+                                -- ^ (final flags, output filename, interface) runPipeline' start_phase hsc_env env input_fn              maybe_loc foreign_os   = do   -- Execute the pipeline...-  let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os }--  evalP (pipeLoop start_phase input_fn) env state+  let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os, iface = Nothing }+  (pipe_state, fp) <- evalP (pipeLoop start_phase input_fn) env state+  return (pipeStateDynFlags pipe_state, fp, pipeStateModIface pipe_state)  -- --------------------------------------------------------------------------- -- outer pipeline loop  -- | pipeLoop runs phases until we reach the stop phase-pipeLoop :: PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath)+pipeLoop :: PhasePlus -> FilePath -> CompPipeline FilePath pipeLoop phase input_fn = do   env <- getPipeEnv   dflags <- getDynFlags@@ -713,7 +727,7 @@         -- further compilation stages can tell what the original filename was.         case output_spec env of         Temporary _ ->-            return (dflags, input_fn)+            return input_fn         output ->             do pst <- getPipeState                final_fn <- liftIO $ getOutputFilename@@ -723,7 +737,7 @@                   let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'")                       line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n")                   liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn-               return (dflags, final_fn)+               return final_fn        | not (realPhase `happensBefore'` stopPhase)@@ -738,17 +752,22 @@      -> do liftIO $ debugTraceMsg dflags 4                                   (text "Running phase" <+> ppr phase)            (next_phase, output_fn) <- runHookedPhase phase input_fn dflags-           r <- pipeLoop next_phase output_fn            case phase of-               HscOut {} ->-                   whenGeneratingDynamicToo dflags $ do-                       setDynFlags $ dynamicTooMkDynamicDynFlags dflags-                       -- TODO shouldn't ignore result:-                       _ <- pipeLoop phase input_fn-                       return ()-               _ ->-                   return ()-           return r+               HscOut {} -> do+                   -- We don't pass Opt_BuildDynamicToo to the backend+                   -- in DynFlags.+                   -- Instead it's run twice with flags accordingly set+                   -- per run.+                   let noDynToo = pipeLoop next_phase output_fn+                   let dynToo = do+                          setDynFlags $ gopt_unset dflags Opt_BuildDynamicToo+                          r <- pipeLoop next_phase output_fn+                          setDynFlags $ dynamicTooMkDynamicDynFlags dflags+                          -- TODO shouldn't ignore result:+                          _ <- pipeLoop phase input_fn+                          return r+                   ifGeneratingDynamicToo dflags dynToo noDynToo+               _ -> pipeLoop next_phase output_fn  runHookedPhase :: PhasePlus -> FilePath -> DynFlags                -> CompPipeline (PhasePlus, FilePath)@@ -821,7 +840,7 @@                        As _    | keep_s     -> True                        LlvmOpt | keep_bc    -> True                        HCc     | keep_hc    -> True-                       HsPp _  | keep_hscpp -> True   -- See Trac #10869+                       HsPp _  | keep_hscpp -> True   -- See #10869                        _other               -> False            suffix = myPhaseInputExt next_phase@@ -870,8 +889,8 @@                                  , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ]     ++ [("", "-mattr=" ++ attrs) | not (null attrs) ] -  where target = LLVM_TARGET-        Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets dflags)+  where target = platformMisc_llvmTarget $ platformMisc dflags+        Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets $ llvmConfig dflags)          -- Relocation models         rmodel | gopt Opt_PIC dflags        = "pic"@@ -1115,9 +1134,13 @@    -- run the compiler!         let msg hsc_env _ what _ = oneShotMsg hsc_env what-        (result, _) <- liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'+        (result, _mod_details, plugin_dflags) <-+          liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'                             mod_summary source_unchanged Nothing (1,1) +        -- In the rest of the pipeline use the dflags with plugin info+        setDynFlags plugin_dflags+         return (HscOut src_flavour mod_name result,                 panic "HscOut doesn't have an input filename") @@ -1127,24 +1150,24 @@          let o_file = ml_obj_file location -- The real object file             hsc_lang = hscTarget dflags-            next_phase = hscPostBackendPhase dflags src_flavour hsc_lang+            next_phase = hscPostBackendPhase src_flavour hsc_lang          case result of-            HscNotGeneratingCode ->+            HscNotGeneratingCode _ ->                 return (RealPhase StopLn,                         panic "No output filename from Hsc when no-code")-            HscUpToDate ->+            HscUpToDate _ ->                 do liftIO $ touchObjectFile dflags o_file                    -- The .o file must have a later modification date                    -- than the source file (else we wouldn't get Nothing)                    -- but we touch it anyway, to keep 'make' happy (we think).                    return (RealPhase StopLn, o_file)-            HscUpdateBoot ->+            HscUpdateBoot _ ->                 do -- In the case of hs-boot files, generate a dummy .o-boot                    -- stamp file for the benefit of Make                    liftIO $ touchObjectFile dflags o_file                    return (RealPhase StopLn, o_file)-            HscUpdateSig ->+            HscUpdateSig _ ->                 do -- We need to create a REAL but empty .o file                    -- because we are going to attempt to put it in a library                    PipeState{hsc_env=hsc_env'} <- getPipeState@@ -1152,13 +1175,25 @@                        basename = dropExtension input_fn                    liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name                    return (RealPhase StopLn, o_file)-            HscRecomp cgguts mod_summary+            HscRecomp { hscs_guts = cgguts,+                        hscs_mod_location = mod_location,+                        hscs_partial_iface = partial_iface,+                        hscs_old_iface_hash = mb_old_iface_hash,+                        hscs_iface_dflags = iface_dflags }               -> do output_fn <- phaseOutputFilename next_phase                      PipeState{hsc_env=hsc_env'} <- getPipeState                      (outputFilename, mStub, foreign_files) <- liftIO $-                      hscGenHardCode hsc_env' cgguts mod_summary output_fn+                      hscGenHardCode hsc_env' cgguts mod_location output_fn++                    final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface)+                    setIface final_iface++                    -- See Note [Writing interface files]+                    let if_dflags = dflags `gopt_unset` Opt_BuildDynamicToo+                    liftIO $ hscMaybeWriteIface if_dflags final_iface mb_old_iface_hash mod_location+                     stub_o <- liftIO (mapM (compileStub hsc_env') mStub)                     foreign_os <- liftIO $                       mapM (uncurry (compileForeign hsc_env')) foreign_files@@ -1170,25 +1205,18 @@ -- Cmm phase  runPhase (RealPhase CmmCpp) input_fn dflags-  = do-       output_fn <- phaseOutputFilename Cmm+  = do output_fn <- phaseOutputFilename Cmm        liftIO $ doCpp dflags False{-not raw-}                       input_fn output_fn        return (RealPhase Cmm, output_fn)  runPhase (RealPhase Cmm) input_fn dflags-  = do-        let hsc_lang = hscTarget dflags--        let next_phase = hscPostBackendPhase dflags HsSrcFile hsc_lang--        output_fn <- phaseOutputFilename next_phase--        PipeState{hsc_env} <- getPipeState--        liftIO $ hscCompileCmmFile hsc_env input_fn output_fn--        return (RealPhase next_phase, output_fn)+  = do let hsc_lang = hscTarget dflags+       let next_phase = hscPostBackendPhase HsSrcFile hsc_lang+       output_fn <- phaseOutputFilename next_phase+       PipeState{hsc_env} <- getPipeState+       liftIO $ hscCompileCmmFile hsc_env input_fn output_fn+       return (RealPhase next_phase, output_fn)  ----------------------------------------------------------------------------- -- Cc phase@@ -1272,17 +1300,8 @@          ghcVersionH <- liftIO $ getGhcVersionPathName dflags -        let gcc_lang_opt | cc_phase `eqPhase` Ccxx    = "c++"-                         | cc_phase `eqPhase` Cobjc   = "objective-c"-                         | cc_phase `eqPhase` Cobjcxx = "objective-c++"-                         | otherwise                  = "c"-        liftIO $ SysTools.runCc dflags (-                -- force the C compiler to interpret this file as C when-                -- compiling .hc files, by adding the -x c option.-                -- Also useful for plain .c files, just in case GHC saw a-                -- -x c option.-                        [ SysTools.Option "-x", SysTools.Option gcc_lang_opt-                        , SysTools.FileOption "" input_fn+        liftIO $ SysTools.runCc (phaseForeignLanguage cc_phase) dflags (+                        [ SysTools.FileOption "" input_fn                         , SysTools.Option "-o"                         , SysTools.FileOption "" output_fn                         ]@@ -1331,50 +1350,18 @@         return (RealPhase next_phase, output_fn)  -------------------------------------------------------------------------------- Splitting phase--runPhase (RealPhase Splitter) input_fn dflags-  = do  -- tmp_pfx is the prefix used for the split .s files--        split_s_prefix <--          liftIO $ newTempName dflags TFL_CurrentModule "split"-        let n_files_fn = split_s_prefix--        liftIO $ SysTools.runSplit dflags-                          [ SysTools.FileOption "" input_fn-                          , SysTools.FileOption "" split_s_prefix-                          , SysTools.FileOption "" n_files_fn-                          ]--        -- Save the number of split files for future references-        s <- liftIO $ readFile n_files_fn-        let n_files = read s :: Int-            dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) }--        setDynFlags dflags'--        -- Remember to delete all these files-        liftIO $ addFilesToClean dflags' TFL_CurrentModule $-                                 [ split_s_prefix ++ "__" ++ show n ++ ".s"-                                 | n <- [1..n_files]]--        return (RealPhase SplitAs,-                "**splitter**") -- we don't use the filename in SplitAs------------------------------------------------------------------------------- -- As, SpitAs phase : Assembler --- This is for calling the assembler on a regular assembly file (not split).+-- This is for calling the assembler on a regular assembly file runPhase (RealPhase (As with_cpp)) input_fn dflags   = do         -- LLVM from version 3.0 onwards doesn't support the OS X system         -- assembler, so we use clang as the assembler instead. (#5636)-        let whichAsProg | hscTarget dflags == HscLlvm &&-                          platformOS (targetPlatform dflags) == OSDarwin-                        = return SysTools.runClang-                        | otherwise = return SysTools.runAs+        let as_prog | hscTarget dflags == HscLlvm &&+                      platformOS (targetPlatform dflags) == OSDarwin+                    = SysTools.runClang+                    | otherwise = SysTools.runAs -        as_prog <- whichAsProg         let cmdline_include_paths = includePaths dflags         let pic_c_flags = picCCOpts dflags @@ -1391,7 +1378,10 @@         let local_includes = [ SysTools.Option ("-iquote" ++ p)                              | p <- includePathsQuote cmdline_include_paths ]         let runAssembler inputFilename outputFilename-                = liftIO $ as_prog dflags+              = liftIO $ do+                  withAtomicRename outputFilename $ \temp_outputFilename -> do+                    as_prog+                       dflags                        (local_includes ++ global_includes                        -- See Note [-fPIC for assembler]                        ++ map SysTools.Option pic_c_flags@@ -1421,104 +1411,15 @@                           , SysTools.Option "-c"                           , SysTools.FileOption "" inputFilename                           , SysTools.Option "-o"-                          , SysTools.FileOption "" outputFilename+                          , SysTools.FileOption "" temp_outputFilename                           ])          liftIO $ debugTraceMsg dflags 4 (text "Running the assembler")         runAssembler input_fn output_fn-        return (RealPhase next_phase, output_fn) ---- This is for calling the assembler on a split assembly file (so a collection--- of assembly files)-runPhase (RealPhase SplitAs) _input_fn dflags-  = do-        -- we'll handle the stub_o file in this phase, so don't MergeForeign,-        -- just jump straight to StopLn afterwards.-        let next_phase = StopLn-        output_fn <- phaseOutputFilename next_phase--        let base_o = dropExtension output_fn-            osuf = objectSuf dflags-            split_odir  = base_o ++ "_" ++ osuf ++ "_split"--        let pic_c_flags = picCCOpts dflags--        -- this also creates the hierarchy-        liftIO $ createDirectoryIfMissing True split_odir--        -- remove M_split/ *.o, because we're going to archive M_split/ *.o-        -- later and we don't want to pick up any old objects.-        fs <- liftIO $ getDirectoryContents split_odir-        liftIO $ mapM_ removeFile $-                map (split_odir </>) $ filter (osuf `isSuffixOf`) fs--        let (split_s_prefix, n) = case splitInfo dflags of-                                  Nothing -> panic "No split info"-                                  Just x -> x--        let split_s   n = split_s_prefix ++ "__" ++ show n <.> "s"--            split_obj :: Int -> FilePath-            split_obj n = split_odir </>-                          takeFileName base_o ++ "__" ++ show n <.> osuf--        let assemble_file n-              = SysTools.runAs dflags (--        -- We only support SparcV9 and better because V8 lacks an atomic CAS-        -- instruction so we have to make sure that the assembler accepts the-        -- instruction set. Note that the user can still override this-        -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag-        -- regardless of the ordering.-        ---        -- This is a temporary hack.-                          (if platformArch (targetPlatform dflags) == ArchSPARC-                           then [SysTools.Option "-mcpu=v9"]-                           else []) ++--                          -- See Note [-fPIC for assembler]-                          map SysTools.Option pic_c_flags ++--                          [ SysTools.Option "-c"-                          , SysTools.Option "-o"-                          , SysTools.FileOption "" (split_obj n)-                          , SysTools.FileOption "" (split_s n)-                          ])--        liftIO $ mapM_ assemble_file [1..n]--        -- Note [pipeline-split-init]-        -- If we have a stub file -- which will be part of foreign_os ---        --  it may contain constructor-        -- functions for initialisation of this module.  We can't-        -- simply leave the stub as a separate object file, because it-        -- will never be linked in: nothing refers to it.  We need to-        -- ensure that if we ever refer to the data in this module-        -- that needs initialisation, then we also pull in the-        -- initialisation routine.-        ---        -- To that end, we make a DANGEROUS ASSUMPTION here: the data-        -- that needs to be initialised is all in the FIRST split-        -- object.  See Note [codegen-split-init].-        ---        -- We also merge in all the foreign objects since we're at it.--        PipeState{foreign_os} <- getPipeState-        if null foreign_os-          then return ()-          else liftIO $ do-             tmp_split_1 <- newTempName dflags TFL_CurrentModule osuf-             let split_1 = split_obj 1-             copyFile split_1 tmp_split_1-             removeFile split_1-             joinObjectFiles dflags (tmp_split_1 : foreign_os) split_1--        -- join them into a single .o file-        liftIO $ joinObjectFiles dflags (map split_obj [1..n]) output_fn-         return (RealPhase next_phase, output_fn) + ----------------------------------------------------------------------------- -- LlvmOpt phase runPhase (RealPhase LlvmOpt) input_fn dflags@@ -1538,7 +1439,7 @@         -- we always (unless -optlo specified) run Opt since we rely on it to         -- fix up some pretty big deficiencies in the code we generate         optIdx = max 0 $ min 2 $ optLevel dflags  -- ensure we're in [0,2]-        llvmOpts = case lookup optIdx $ llvmPasses dflags of+        llvmOpts = case lookup optIdx $ llvmPasses $ llvmConfig dflags of                     Just passes -> passes                     Nothing -> panic ("runPhase LlvmOpt: llvm-passes file "                                       ++ "is missing passes for level "@@ -1560,13 +1461,10 @@  runPhase (RealPhase LlvmLlc) input_fn dflags   = do-    next_phase <- if fastLlvmPipeline dflags-                  then maybeMergeForeign-                  -- hidden debugging flag '-dno-llvm-mangler' to skip mangling-                  else case gopt Opt_NoLlvmMangler dflags of-                         False                            -> return LlvmMangle-                         True | gopt Opt_SplitObjs dflags -> return Splitter-                         True                             -> return (As False)+    next_phase <- if | fastLlvmPipeline dflags -> maybeMergeForeign+                     -- hidden debugging flag '-dno-llvm-mangler' to skip mangling+                     | gopt Opt_NoLlvmMangler dflags -> return (As False)+                     | otherwise -> return LlvmMangle      output_fn <- phaseOutputFilename next_phase @@ -1638,7 +1536,7 @@  runPhase (RealPhase LlvmMangle) input_fn dflags   = do-      let next_phase = if gopt Opt_SplitObjs dflags then Splitter else As False+      let next_phase = As False       output_fn <- phaseOutputFilename next_phase       liftIO $ llvmFixupAsm dflags input_fn output_fn       return (RealPhase next_phase, output_fn)@@ -1761,7 +1659,7 @@ linkBinary' :: Bool -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO () linkBinary' staticLink dflags o_files dep_packages = do     let platform = targetPlatform dflags-        mySettings = settings dflags+        toolSettings' = toolSettings dflags         verbFlags = getVerbFlags dflags         output_fn = exeFileName staticLink dflags @@ -1869,23 +1767,6 @@         -- probably _stub.o files     let extra_ld_inputs = ldInputs dflags -    -- Here are some libs that need to be linked at the *end* of-    -- the command line, because they contain symbols that are referred to-    -- by the RTS.  We can't therefore use the ordinary way opts for these.-    let debug_opts | WayDebug `elem` ways dflags = [-#if defined(HAVE_LIBBFD)-                        "-lbfd", "-liberty"-#endif-                         ]-                   | otherwise                   = []--        thread_opts | WayThreaded `elem` ways dflags = [-#if NEED_PTHREAD_LIB-                        "-lpthread"-#endif-                        ]-                    | otherwise                      = []-     rc_objs <- maybeCreateManifest dflags output_fn      let link = if staticLink@@ -1917,7 +1798,7 @@                       -- like                       --     ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog                       -- on x86.-                      ++ (if sLdSupportsCompactUnwind mySettings &&+                      ++ (if toolSettings_ldSupportsCompactUnwind toolSettings' &&                              not staticLink &&                              (platformOS platform == OSDarwin) &&                              case platformArch platform of@@ -1941,7 +1822,7 @@                           then ["-Wl,-read_only_relocs,suppress"]                           else []) -                      ++ (if sLdIsGnuLd mySettings &&+                      ++ (if toolSettings_ldIsGnuLd toolSettings' &&                              not (gopt Opt_WholeArchiveHsLibs dflags)                           then ["-Wl,--gc-sections"]                           else [])@@ -1956,8 +1837,6 @@                       ++ extraLinkObj:noteLinkObjs                       ++ pkg_link_opts                       ++ pkg_framework_opts-                      ++ debug_opts-                      ++ thread_opts                       ++ (if platformOS platform == OSDarwin                           then [ "-Wl,-dead_strip_dylibs" ]                           else [])@@ -2068,7 +1947,7 @@         <$> (Archive <$> mapM loadObj modules)         <*> mapM loadAr archives -  if sLdIsGnuLd (settings dflags)+  if toolSettings_ldIsGnuLd (toolSettings dflags)     then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar     else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar @@ -2093,13 +1972,15 @@     let verbFlags = getVerbFlags dflags      let cpp_prog args | raw       = SysTools.runCpp dflags args-                      | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)+                      | otherwise = SysTools.runCc Nothing dflags (SysTools.Option "-E" : args) +    let targetArch = stringEncodeArch $ platformArch $ targetPlatform dflags+        targetOS = stringEncodeOS $ platformOS $ targetPlatform dflags     let target_defs =           [ "-D" ++ HOST_OS     ++ "_BUILD_OS",             "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH",-            "-D" ++ TARGET_OS   ++ "_HOST_OS",-            "-D" ++ TARGET_ARCH ++ "_HOST_ARCH" ]+            "-D" ++ targetOS    ++ "_HOST_OS",+            "-D" ++ targetArch  ++ "_HOST_ARCH" ]         -- remember, in code we *compile*, the HOST is the same our TARGET,         -- and BUILD is the same as our HOST. @@ -2133,7 +2014,7 @@                     -- Include version macros for every *exposed* package.                     -- Without -hide-all-packages and with a package database                     -- size of 1000 packages, it takes cpp an estimated 2-                    -- milliseconds to process this file. See Trac #10970+                    -- milliseconds to process this file. See #10970                     -- comment 8.                     return [SysTools.FileOption "-include" macro_stub]             else return []@@ -2187,7 +2068,7 @@  generatePackageVersionMacros :: [PackageConfig] -> String generatePackageVersionMacros pkgs = concat-  -- Do not add any C-style comments. See Trac #3389.+  -- Do not add any C-style comments. See #3389.   [ generateMacros "" pkgname version   | pkg <- pkgs   , let version = packageVersion pkg@@ -2242,15 +2123,15 @@  joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO () joinObjectFiles dflags o_files output_fn = do-  let mySettings = settings dflags-      ldIsGnuLd = sLdIsGnuLd mySettings+  let toolSettings' = toolSettings dflags+      ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'       osInfo = platformOS (targetPlatform dflags)       ld_r args cc = SysTools.runLink dflags ([                        SysTools.Option "-nostdlib",                        SysTools.Option "-Wl,-r"                      ]                         -- See Note [No PIE while linking] in DynFlags-                     ++ (if sGccSupportsNoPie mySettings+                     ++ (if toolSettings_ccSupportsNoPie toolSettings'                           then [SysTools.Option "-no-pie"]                           else []) @@ -2281,7 +2162,7 @@       -- suppress the generation of the .note.gnu.build-id section,       -- which we don't need and sometimes causes ld to emit a       -- warning:-      ld_build_id | sLdSupportsBuildId mySettings = ["-Wl,--build-id=none"]+      ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["-Wl,--build-id=none"]                   | otherwise                     = []    ccInfo <- getCompilerInfo dflags@@ -2292,7 +2173,7 @@           let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files           writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")"           ld_r [SysTools.FileOption "" script] ccInfo-     else if sLdSupportsFilelist mySettings+     else if toolSettings_ldSupportsFilelist toolSettings'      then do           filelist <- newTempName dflags TFL_CurrentModule "filelist"           writeFile filelist $ unlines o_files@@ -2322,14 +2203,13 @@              return (t2 <= src_timestamp)  -- | What phase to run after one of the backend code generators has run-hscPostBackendPhase :: DynFlags -> HscSource -> HscTarget -> Phase-hscPostBackendPhase _ HsBootFile _    =  StopLn-hscPostBackendPhase _ HsigFile _      =  StopLn-hscPostBackendPhase dflags _ hsc_lang =+hscPostBackendPhase :: HscSource -> HscTarget -> Phase+hscPostBackendPhase HsBootFile _    =  StopLn+hscPostBackendPhase HsigFile _      =  StopLn+hscPostBackendPhase _ hsc_lang =   case hsc_lang of-        HscC -> HCc-        HscAsm | gopt Opt_SplitObjs dflags -> Splitter-               | otherwise                 -> As False+        HscC           -> HCc+        HscAsm         -> As False         HscLlvm        -> LlvmOpt         HscNothing     -> StopLn         HscInterpreted -> StopLn
compiler/main/DynamicLoading.hs view
@@ -3,7 +3,6 @@ -- | Dynamically lookup up values from modules and loading them. module DynamicLoading (         initializePlugins,-#if defined(GHCI)         -- * Loading plugins         loadFrontendPlugin, @@ -19,15 +18,11 @@         getValueSafely,         getHValueSafely,         lessUnsafeCoerce-#else-        pluginError-#endif     ) where  import GhcPrelude import DynFlags -#if defined(GHCI) import Linker           ( linkModule, getHValue ) import GHCi             ( wormhole ) import SrcLoc           ( noSrcSpan )@@ -44,7 +39,8 @@  import HscTypes import GHCi.RemoteTypes ( HValue )-import Type             ( Type, eqType, mkTyConTy, pprTyThingCategory )+import Type             ( Type, eqType, mkTyConTy )+import TyCoPpr          ( pprTyThingCategory ) import TyCon            ( TyCon ) import Name             ( Name, nameModule_maybe ) import Id               ( idType )@@ -60,28 +56,11 @@ import Data.Maybe        ( mapMaybe ) import GHC.Exts          ( unsafeCoerce# ) -#else--import HscTypes         ( HscEnv )-import Module           ( ModuleName, moduleNameString )-import Panic--import Data.List        ( intercalate )-import Control.Monad    ( unless )--#endif- -- | Loads the plugins specified in the pluginModNames field of the dynamic -- flags. Should be called after command line arguments are parsed, but before -- actual compilation starts. Idempotent operation. Should be re-called if -- pluginModNames or pluginModNameOpts changes. initializePlugins :: HscEnv -> DynFlags -> IO DynFlags-#if !defined(GHCI)-initializePlugins _ df-  = do let pluginMods = pluginModNames df-       unless (null pluginMods) (pluginError pluginMods)-       return df-#else initializePlugins hsc_env df   | map lpModuleName (cachedPlugins df)          == pluginModNames df -- plugins not changed@@ -91,12 +70,12 @@   = return df -- no need to reload plugins   | otherwise   = do loadedPlugins <- loadPlugins (hsc_env { hsc_dflags = df })-       return $ df { cachedPlugins = loadedPlugins }-  where argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst)-#endif-+       let df' = df { cachedPlugins = loadedPlugins }+       df'' <- withPlugins df' runDflagsPlugin df'+       return df'' -#if defined(GHCI)+  where argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst)+        runDflagsPlugin p opts dynflags = dynflagsPlugin p opts dynflags  loadPlugins :: HscEnv -> IO [LoadedPlugin] loadPlugins hsc_env@@ -302,15 +281,3 @@  throwCmdLineError :: String -> IO a throwCmdLineError = throwGhcExceptionIO . CmdLineError--#else--pluginError :: [ModuleName] -> a-pluginError modnames = throwGhcException (CmdLineError msg)-  where-    msg = "not built for interactive use - can't load plugins ("-            -- module names are not z-encoded-          ++ intercalate ", " (map moduleNameString modnames)-          ++ ")"--#endif
compiler/main/Finder.hs view
@@ -31,7 +31,7 @@    ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -245,7 +245,7 @@  mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule mkHomeInstalledModule dflags mod_name =-  let iuid = fst (splitUnitIdInsts (thisPackage dflags))+  let iuid = thisInstalledUnitId dflags   in InstalledModule iuid mod_name  -- This returns a module because it's more convenient for users@@ -313,8 +313,10 @@       , ("lhsig",  mkHomeModLocationSearched dflags mod_name "lhsig")       ] -     hi_exts = [ (hisuf,                mkHiOnlyModLocation dflags hisuf)-               , (addBootSuffix hisuf,  mkHiOnlyModLocation dflags hisuf)+     -- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that+     -- when hiDir field is set in dflags, we know to look there (see #16500)+     hi_exts = [ (hisuf,                mkHomeModHiOnlyLocation dflags mod_name)+               , (addBootSuffix hisuf,  mkHomeModHiOnlyLocation dflags mod_name)                ]          -- In compilation manager modes, we look for source files in the home@@ -488,6 +490,15 @@                         ml_hi_file   = hi_fn,                         ml_obj_file  = obj_fn,                         ml_hie_file  = hie_fn })++mkHomeModHiOnlyLocation :: DynFlags+                        -> ModuleName+                        -> FilePath+                        -> BaseName+                        -> IO ModLocation+mkHomeModHiOnlyLocation dflags mod path basename = do+   loc <- mkHomeModLocation2 dflags mod (path </> basename) ""+   return loc { ml_hs_file = Nothing }  mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String                     -> IO ModLocation
compiler/main/GHC.hs view
@@ -85,7 +85,7 @@         lookupGlobalName,         findGlobalAnns,         mkPrintUnqualifiedForModule,-        ModIface(..),+        ModIface, ModIface_(..),         SafeHaskellMode(..),          -- * Querying the environment@@ -139,7 +139,7 @@         getDocs, GetDocsFailure(..),          -- ** Other-        runTcInteractive,   -- Desired by some clients (Trac #8878)+        runTcInteractive,   -- Desired by some clients (#8878)         isStmt, hasImport, isImport, isDecl,          -- ** The debugger@@ -220,12 +220,14 @@         Kind,         PredType,         ThetaType, pprForAll, pprThetaArrowTy,+        parseInstanceHead,+        getInstancesForType,          -- ** Entities         TyThing(..),          -- ** Syntax-        module HsSyn, -- ToDo: remove extraneous bits+        module GHC.Hs, -- ToDo: remove extraneous bits          -- ** Fixities         FixityDirection(..),@@ -291,7 +293,7 @@   * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt. -} -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude hiding (init) @@ -309,15 +311,17 @@ import TcRnMonad        ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) import LoadIface        ( loadSysInterface ) import TcRnTypes+import Predicate import Packages import NameSet import RdrName-import HsSyn+import GHC.Hs import Type     hiding( typeKind )-import TcType           hiding( typeKind )+import TcType import Id import TysPrim          ( alphaTyVars ) import TyCon+import TyCoPpr          ( pprForAll ) import Class import DataCon import Name             hiding ( varName )@@ -337,8 +341,8 @@ import Annotations import Module import Panic-import Platform-import Bag              ( listToBag, unitBag )+import GHC.Platform+import Bag              ( listToBag ) import ErrUtils import MonadUtils import Util@@ -503,7 +507,7 @@   = do { env <- liftIO $                 do { top_dir <- findTopDir mb_top_dir                    ; mySettings <- initSysTools top_dir-                   ; myLlvmConfig <- initLlvmConfig top_dir+                   ; myLlvmConfig <- lazyInitLlvmConfig top_dir                    ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig)                    ; checkBrokenTablesNextToCode dflags                    ; setUnsafeGlobalDynFlags dflags@@ -517,7 +521,7 @@ -- check should be more selective but there is currently no released -- version where this bug is fixed. -- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and--- https://ghc.haskell.org/trac/ghc/ticket/4210#comment:29+-- https://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333 checkBrokenTablesNextToCode :: MonadIO m => DynFlags -> m () checkBrokenTablesNextToCode dflags   = do { broken <- checkBrokenTablesNextToCode' dflags@@ -684,14 +688,12 @@ checkNewInteractiveDynFlags dflags0 = do   -- We currently don't support use of StaticPointers in expressions entered on   -- the REPL. See #12356.-  dflags1 <--      if xopt LangExt.StaticPointers dflags0-      then do liftIO $ printOrThrowWarnings dflags0 $ listToBag-                [mkPlainWarnMsg dflags0 interactiveSrcSpan-                 $ text "StaticPointers is not supported in GHCi interactive expressions."]-              return $ xopt_unset dflags0 LangExt.StaticPointers-      else return dflags0-  return dflags1+  if xopt LangExt.StaticPointers dflags0+  then do liftIO $ printOrThrowWarnings dflags0 $ listToBag+            [mkPlainWarnMsg dflags0 interactiveSrcSpan+             $ text "StaticPointers is not supported in GHCi interactive expressions."]+          return $ xopt_unset dflags0 LangExt.StaticPointers+  else return dflags0   -- %************************************************************************@@ -1367,9 +1369,9 @@   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1   case lexTokenStream source startLoc flags of     POk _ ts  -> return ts-    PFailed _ span err ->+    PFailed pst ->         do dflags <- getDynFlags-           liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)+           throwErrors (getErrorMessages pst dflags)  -- | Give even more information on the source than 'getTokenStream' -- This function allows reconstructing the source completely with@@ -1380,9 +1382,9 @@   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1   case lexTokenStream source startLoc flags of     POk _ ts -> return $ addSourceToTokens startLoc source ts-    PFailed _ span err ->+    PFailed pst ->         do dflags <- getDynFlags-           liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)+           throwErrors (getErrorMessages pst dflags)  -- | Given a source location and a StringBuffer corresponding to this -- location, return a rich token stream with the source associated to the@@ -1557,9 +1559,9 @@    in    case unP Parser.parseModule (mkPState dflags buf loc) of -     PFailed warnFn span err   ->-         let (warns,_) = warnFn dflags in-         (warns, Left $ unitBag (mkPlainErrMsg dflags span err))+     PFailed pst ->+         let (warns,errs) = getMessages pst dflags in+         (warns, Left errs)       POk pst rdr_module ->          let (warns,_) = getMessages pst dflags in
compiler/main/GhcMake.hs view
@@ -29,7 +29,7 @@         moduleGraphNodes, SummaryNode     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -66,9 +66,9 @@ import Packages import UniqSet import Util+import qualified GHC.LanguageExtensions as LangExt import NameEnv import FileCleanup-import qualified GHC.LanguageExtensions as LangExt  import Data.Either ( rights, partitionEithers ) import qualified Data.Map as Map@@ -154,7 +154,7 @@          targets = hsc_targets hsc_env          old_graph = hsc_mod_graph hsc_env -  withTiming (pure dflags) (text "Chasing dependencies") (const ()) $ do+  withTiming dflags (text "Chasing dependencies") (const ()) $ do     liftIO $ debugTraceMsg dflags 2 (hcat [               text "Chasing modules from: ",               hcat (punctuate comma (map pprTarget targets))])@@ -185,7 +185,7 @@ -- but "A" imports some other module "C", then GHC will issue a warning -- about module "C" not being listed in a command line. ----- The warning in enabled by `-Wmissing-home-modules`. See Trac #13129+-- The warning in enabled by `-Wmissing-home-modules`. See #13129 warnMissingHomeModules :: GhcMonad m => HscEnv -> ModuleGraph -> m () warnMissingHomeModules hsc_env mod_graph =     when (wopt Opt_WarnMissingHomeModules dflags && not (null missing)) $@@ -203,7 +203,7 @@     -- For instance, `ghc --make src-exe/Main.hs` and     -- `ghc --make -isrc-exe Main` are supposed to be equivalent.     -- Note also that we can't always infer the associated module name-    -- directly from the filename argument.  See Trac #13727.+    -- directly from the filename argument.  See #13727.     is_my_target mod (TargetModule name)       = moduleName (ms_mod mod) == name     is_my_target mod (TargetFile target_file _)@@ -267,8 +267,76 @@ load :: GhcMonad m => LoadHowMuch -> m SuccessFlag load how_much = do     mod_graph <- depanal [] False-    load' how_much (Just batchMsg) mod_graph+    success <- load' how_much (Just batchMsg) mod_graph+    warnUnusedPackages+    pure success +-- Note [Unused packages]+--+-- Cabal passes `--package-id` flag for each direct dependency. But GHC+-- loads them lazily, so when compilation is done, we have a list of all+-- actually loaded packages. All the packages, specified on command line,+-- but never loaded, are probably unused dependencies.++warnUnusedPackages :: GhcMonad m => m ()+warnUnusedPackages = do+    hsc_env <- getSession+    eps <- liftIO $ hscEPS hsc_env++    let dflags = hsc_dflags hsc_env+        pit = eps_PIT eps++    let loadedPackages+          = map (getPackageDetails dflags)+          . nub . sort+          . map moduleUnitId+          . moduleEnvKeys+          $ pit++        requestedArgs = mapMaybe packageArg (packageFlags dflags)++        unusedArgs+          = filter (\arg -> not $ any (matching dflags arg) loadedPackages)+                   requestedArgs++    let warn = makeIntoWarning+          (Reason Opt_WarnUnusedPackages)+          (mkPlainErrMsg dflags noSrcSpan msg)+        msg = vcat [ text "The following packages were specified" <+>+                     text "via -package or -package-id flags,"+                   , text "but were not needed for compilation:"+                   , nest 2 (vcat (map (withDash . pprUnusedArg) unusedArgs)) ]++    when (wopt Opt_WarnUnusedPackages dflags && not (null unusedArgs)) $+      logWarnings (listToBag [warn])++    where+        packageArg (ExposePackage _ arg _) = Just arg+        packageArg _ = Nothing++        pprUnusedArg (PackageArg str) = text str+        pprUnusedArg (UnitIdArg uid) = ppr uid++        withDash = (<+>) (text "-")++        matchingStr :: String -> PackageConfig -> Bool+        matchingStr str p+                =  str == sourcePackageIdString p+                || str == packageNameString p++        matching :: DynFlags -> PackageArg -> PackageConfig -> Bool+        matching _ (PackageArg str) p = matchingStr str p+        matching dflags (UnitIdArg uid) p = uid == realUnitId dflags p++        -- For wired-in packages, we have to unwire their id,+        -- otherwise they won't match package flags+        realUnitId :: DynFlags -> PackageConfig -> UnitId+        realUnitId dflags+          = unwireUnitId dflags+          . DefiniteUnitId+          . DefUnitId+          . installedPackageConfigId+ -- | Generalized version of 'load' which also supports a custom -- 'Messager' (for reporting progress) and 'ModuleGraph' (generally -- produced by calling 'depanal'.@@ -424,8 +492,8 @@                    | otherwise  = upsweep      setSession hsc_env{ hsc_HPT = emptyHomePackageTable }-    (upsweep_ok, modsUpswept)-       <- upsweep_fn mHscMessage pruned_hpt stable_mods cleanup mg+    (upsweep_ok, modsUpswept) <- withDeferredDiagnostics $+      upsweep_fn mHscMessage pruned_hpt stable_mods cleanup mg      -- Make modsDone be the summaries for each home module now     -- available; this should equal the domain of hpt3.@@ -897,7 +965,7 @@             n_cpus <- getNumProcessors             -- Setting number of capabilities more than             -- CPU count usually leads to high userspace-            -- lock contention. Trac #9221+            -- lock contention. #9221             let n_caps = min n_jobs n_cpus             unless (n_capabilities /= 1) $ setNumCapabilities n_caps             return n_capabilities@@ -1289,6 +1357,25 @@  where   done_holes = emptyUniqSet +  keep_going this_mods old_hpt done mods mod_index nmods uids_to_check done_holes = do+    let sum_deps ms (AcyclicSCC mod) =+          if any (flip elem . map (unLoc . snd) $ ms_imps mod) ms+            then ms_mod_name mod:ms+            else ms+        sum_deps ms _ = ms+        dep_closure = foldl' sum_deps this_mods mods+        dropped_ms = drop (length this_mods) (reverse dep_closure)+        prunable (AcyclicSCC mod) = elem (ms_mod_name mod) dep_closure+        prunable _ = False+        mods' = filter (not . prunable) mods+        nmods' = nmods - length dropped_ms++    when (not $ null dropped_ms) $ do+        dflags <- getSessionDynFlags+        liftIO $ fatalErrorMsg dflags (keepGoingPruneErr dropped_ms)+    (_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods' uids_to_check done_holes+    return (Failed, done')+   upsweep'     :: GhcMonad m     => HomePackageTable@@ -1306,10 +1393,13 @@         return (Succeeded, done)    upsweep' _old_hpt done-     (CyclicSCC ms:_) _ _ _ _+     (CyclicSCC ms:mods) mod_index nmods uids_to_check done_holes    = do dflags <- getSessionDynFlags         liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)-        return (Failed, done)+        if gopt Opt_KeepGoing dflags+          then keep_going (map ms_mod_name ms) old_hpt done mods mod_index nmods+                          uids_to_check done_holes+          else return (Failed, done)    upsweep' old_hpt done      (AcyclicSCC mod:mods) mod_index nmods uids_to_check done_holes@@ -1358,7 +1448,12 @@                  return (Just mod_info)          case mb_mod_info of-          Nothing -> return (Failed, done)+          Nothing -> do+                dflags <- getSessionDynFlags+                if gopt Opt_KeepGoing dflags+                  then keep_going [ms_mod_name mod] old_hpt done mods mod_index nmods+                                  uids_to_check done_holes+                  else return (Failed, done)           Just mod_info -> do                 let this_mod = ms_mod_name mod @@ -1659,7 +1754,7 @@ -- be any object code that we can compare against, nor should there -- be: we're *just* generating interface files.  In this case, we -- want to check if the interface file is new, in lieu of the object--- file.  See also Trac #9243.+-- file.  See also #9243.  -- Filter modules in the HPT retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable@@ -1980,11 +2075,11 @@        -- See Note [-fno-code mode] #8025        map1 <- if hscTarget dflags == HscNothing          then enableCodeGenForTH-           (defaultObjectTarget (targetPlatform dflags))+           (defaultObjectTarget dflags)            map0          else if hscTarget dflags == HscInterpreted-           then enableCodeGenForUnboxedTuples-             (defaultObjectTarget (targetPlatform dflags))+           then enableCodeGenForUnboxedTuplesOrSums+             (defaultObjectTarget dflags)              map0            else return map0        return $ concat $ nodeMapElts map1@@ -2081,17 +2176,19 @@ -- and .o file locations to be temporary files. -- -- This is used used in order to load code that uses unboxed tuples--- into GHCi while still allowing some code to be interpreted.-enableCodeGenForUnboxedTuples :: HscTarget+-- or sums into GHCi while still allowing some code to be interpreted.+enableCodeGenForUnboxedTuplesOrSums :: HscTarget   -> NodeMap [Either ErrorMessages ModSummary]   -> IO (NodeMap [Either ErrorMessages ModSummary])-enableCodeGenForUnboxedTuples =+enableCodeGenForUnboxedTuplesOrSums =   enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule   where     condition ms =-      False &&    -- disabled due to #16876-      xopt LangExt.UnboxedTuples (ms_hspp_opts ms) &&+      unboxed_tuples_or_sums (ms_hspp_opts ms) &&+      not (gopt Opt_ByteCode (ms_hspp_opts ms)) &&       not (isBootSummary ms)+    unboxed_tuples_or_sums d =+      xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d     should_modify (ModSummary { ms_hspp_opts = dflags }) =       hscTarget dflags == HscInterpreted @@ -2131,15 +2228,17 @@           -- to by the user. But we need them, so we patch their locations in           -- the ModSummary with temporary files.           ---        hi_file <-+        (hi_file, o_file) <-+          -- If ``-fwrite-interface` is specified, then the .o and .hi files+          -- are written into `-odir` and `-hidir` respectively.  #16670           if gopt Opt_WriteInterface dflags-            then return $ ml_hi_file ms_location-            else new_temp_file (hiSuf dflags) (dynHiSuf dflags)-        o_temp_file <- new_temp_file (objectSuf dflags) (dynObjectSuf dflags)+            then return (ml_hi_file ms_location, ml_obj_file ms_location)+            else (,) <$> (new_temp_file (hiSuf dflags) (dynHiSuf dflags))+                     <*> (new_temp_file (objectSuf dflags) (dynObjectSuf dflags))         return $           ms           { ms_location =-              ms_location {ml_hi_file = hi_file, ml_obj_file = o_temp_file}+              ms_location {ml_hi_file = hi_file, ml_obj_file = o_file}           , ms_hspp_opts = updOptLevel 0 $ dflags {hscTarget = target}           }       | otherwise = return ms@@ -2188,28 +2287,6 @@     concat [ [(m,IsBoot), (m,NotBoot)] | m <- ms_home_srcimps s ]         ++ [ (m,NotBoot) | m <- ms_home_imps s ] -home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]-home_imps imps = [ lmodname |  (mb_pkg, lmodname) <- imps,-                                  isLocal mb_pkg ]-  where isLocal Nothing = True-        isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special-        isLocal _ = False--ms_home_allimps :: ModSummary -> [ModuleName]-ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)---- | Like 'ms_home_imps', but for SOURCE imports.-ms_home_srcimps :: ModSummary -> [Located ModuleName]-ms_home_srcimps = home_imps . ms_srcimps---- | All of the (possibly) home module imports from a--- 'ModSummary'; that is to say, each of these module names--- could be a home import if an appropriately named file--- existed.  (This is in contrast to package qualified--- imports, which are guaranteed not to be home imports.)-ms_home_imps :: ModSummary -> [Located ModuleName]-ms_home_imps = home_imps . ms_imps- ----------------------------------------------------------------------------- -- Summarising modules @@ -2545,6 +2622,41 @@ --                      Error messages ----------------------------------------------------------------------------- +-- Defer and group warning, error and fatal messages so they will not get lost+-- in the regular output.+withDeferredDiagnostics :: GhcMonad m => m a -> m a+withDeferredDiagnostics f = do+  dflags <- getDynFlags+  if not $ gopt Opt_DeferDiagnostics dflags+  then f+  else do+    warnings <- liftIO $ newIORef []+    errors <- liftIO $ newIORef []+    fatals <- liftIO $ newIORef []++    let deferDiagnostics _dflags !reason !severity !srcSpan !style !msg = do+          let action = putLogMsg dflags reason severity srcSpan style msg+          case severity of+            SevWarning -> atomicModifyIORef' warnings $ \i -> (action: i, ())+            SevError -> atomicModifyIORef' errors $ \i -> (action: i, ())+            SevFatal -> atomicModifyIORef' fatals $ \i -> (action: i, ())+            _ -> action++        printDeferredDiagnostics = liftIO $+          forM_ [warnings, errors, fatals] $ \ref -> do+            -- This IORef can leak when the dflags leaks, so let us always+            -- reset the content.+            actions <- atomicModifyIORef' ref $ \i -> ([], i)+            sequence_ $ reverse actions++        setLogAction action = modifySession $ \hsc_env ->+          hsc_env{ hsc_dflags = (hsc_dflags hsc_env){ log_action = action } }++    gbracket+      (setLogAction deferDiagnostics)+      (\_ -> setLogAction (log_action dflags) >> printDeferredDiagnostics)+      (\_ -> f)+ noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg -- ToDo: we don't have a proper line number for this error noModError dflags loc wanted_mod err@@ -2569,6 +2681,12 @@   where     mod = ms_mod summ1     files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs++keepGoingPruneErr :: [ModuleName] -> SDoc+keepGoingPruneErr ms+  = vcat (( text "-fkeep-going in use, removing the following" <+>+            text "dependencies and continuing:"):+          map (nest 6 . ppr) ms )  cyclicModuleErr :: [ModSummary] -> SDoc -- From a strongly connected component we find
compiler/main/GhcPlugins.hs view
@@ -90,7 +90,7 @@ import IfaceEnv         ( lookupOrigIO ) import GhcPrelude import MonadUtils       ( mapMaybeM )-import Convert          ( thRdrNameGuesses )+import GHC.ThToHs       ( thRdrNameGuesses ) import TcEnv            ( lookupGlobal )  import qualified Language.Haskell.TH as TH
compiler/main/HscMain.hs view
@@ -39,6 +39,7 @@     , Messager, batchMsg     , HscStatus (..)     , hscIncrementalCompile+    , hscMaybeWriteIface     , hscCompileCmmFile      , hscGenHardCode@@ -67,6 +68,7 @@     , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls     , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType     , hscParseExpr+    , hscParseType     , hscCompileCoreExpr     -- * Low-level exports for hooks     , hscCompileCoreExpr'@@ -74,7 +76,7 @@       -- hscFileFrontEnd in client code     , hscParse', hscSimplify', hscDesugar', tcRnModule'     , getHscEnv-    , hscSimpleIface', hscNormalIface'+    , hscSimpleIface'     , oneShotMsg     , hscFileFrontEnd, genericHscFrontend, dumpIfaceStats     , ioMsgMaybe@@ -103,8 +105,8 @@ import Module import Packages import RdrName-import HsSyn-import HsDumpAst+import GHC.Hs+import GHC.Hs.Dump import CoreSyn import StringBuffer import Parser@@ -113,6 +115,7 @@ import TcRnDriver import TcIface          ( typecheckIface ) import TcRnMonad+import TcHsSyn          ( ZonkFlexi (DefaultFlexi) ) import NameCache        ( initNameCache ) import LoadIface        ( ifaceStats, initExternalPackageState ) import PrelInfo@@ -122,7 +125,7 @@ import TidyPgm import CorePrep import CoreToStg        ( coreToStg )-import qualified StgCmm ( codeGen )+import qualified GHC.StgToCmm as StgToCmm ( codeGen ) import StgSyn import StgFVs           ( annTopBindingsFreeVars ) import CostCentre@@ -147,7 +150,6 @@  import DynFlags import ErrUtils-import Platform ( platformOS, osSubsectionsViaSymbols )  import Outputable import NameEnv@@ -162,7 +164,7 @@  import Util -import Data.List+import Data.List        ( nub, isPrefixOf, partition ) import Control.Monad import Data.IORef import System.FilePath as FilePath@@ -171,13 +173,14 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.Set (Set)+import Control.DeepSeq (force)  import HieAst           ( mkHieFile )-import HieTypes         ( getAsts, hie_asts )+import HieTypes         ( getAsts, hie_asts, hie_module ) import HieBin           ( readHieFile, writeHieFile , hie_file_result) import HieDebug         ( diffFile, validateScopes ) -#include "GhclibHsVersions.h"+#include "HsVersions.h"   {- **********************************************************************@@ -193,6 +196,7 @@     nc_var  <- newIORef (initNameCache us knownKeyNames)     fc_var  <- newIORef emptyInstalledModuleEnv     iserv_mvar <- newMVar Nothing+    emptyDynLinker <- uninitializedLinker     return HscEnv {  hsc_dflags       = dflags                   ,  hsc_targets      = []                   ,  hsc_mod_graph    = emptyMG@@ -202,7 +206,8 @@                   ,  hsc_NC           = nc_var                   ,  hsc_FC           = fc_var                   ,  hsc_type_env_var = Nothing-                  , hsc_iserv        = iserv_mvar+                  ,  hsc_iserv        = iserv_mvar+                  ,  hsc_dynLinker    = emptyDynLinker                   }  -- -----------------------------------------------------------------------------@@ -233,6 +238,16 @@     logWarnings warns     when (not $ isEmptyBag errs) $ throwErrors errs +-- | Log warnings and throw errors, assuming the messages+-- contain at least one error (e.g. coming from PFailed)+handleWarningsThrowErrors :: Messages -> Hsc a+handleWarningsThrowErrors (warns, errs) = do+    logWarnings warns+    dflags <- getDynFlags+    (wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings+    liftIO $ printBagOfErrors dflags wWarns+    throwErrors (unionBags errs wErrs)+ -- | Deal with errors and warnings returned by a compilation step -- -- In order to reduce dependencies to other parts of the compiler, functions@@ -316,9 +331,8 @@ hscParse' mod_summary  | Just r <- ms_parsed_mod mod_summary = return r  | otherwise = {-# SCC "Parser" #-}-    withTiming getDynFlags-               (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))-               (const ()) $ do+    withTimingD (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))+                (const ()) $ do     dflags <- getDynFlags     let src_filename  = ms_hspp_file mod_summary         maybe_src_buf = ms_hspp_buf  mod_summary@@ -337,19 +351,18 @@                  | otherwise = parseModule      case unP parseMod (mkPState dflags buf loc) of-        PFailed warnFn span err -> do-            logWarningsReportErrors (warnFn dflags)-            handleWarnings-            liftIO $ throwOneError (mkPlainErrMsg dflags span err)-+        PFailed pst ->+            handleWarningsThrowErrors (getMessages pst dflags)         POk pst rdr_module -> do-            logWarningsReportErrors (getMessages pst dflags)+            let (warns, errs) = getMessages pst dflags+            logWarnings warns             liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $                                    ppr rdr_module             liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $                                    showAstData NoBlankSrcSpan rdr_module             liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $                                    ppSourceStats False rdr_module+            when (not $ isEmptyBag errs) $ throwErrors errs              -- To get the list of extra source files, we take the list             -- that the parser gave us,@@ -415,7 +428,8 @@             hs_env <- Hsc $ \e w -> return (e, w)             liftIO $ do               -- Validate Scopes-              case validateScopes $ getAsts $ hie_asts hieFile of+              let mdl = hie_module hieFile+              case validateScopes mdl $ getAsts $ hie_asts hieFile of                   [] -> putMsg dflags $ text "Got valid scopes"                   xs -> do                     putMsg dflags $ text "Got invalid scopes"@@ -485,6 +499,14 @@     hsc_env <- getHscEnv     dflags   <- getDynFlags +    -- -Wmissing-safe-haskell-mode+    when (not (safeHaskellModeEnabled dflags)+          && wopt Opt_WarnMissingSafeHaskellMode dflags) $+        logWarnings $ unitBag $+        makeIntoWarning (Reason Opt_WarnMissingSafeHaskellMode) $+        mkPlainWarnMsg dflags (getLoc (hpm_module mod)) $+        warnMissingSafeHaskellMode+     tcg_res <- {-# SCC "Typecheck-Rename" #-}                ioMsgMaybe $                    tcRnModule hsc_env sum@@ -531,6 +553,8 @@     errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!"     errTwthySafe t = quotes (pprMod t)       <+> text "is marked as Trustworthy but has been inferred as safe!"+    warnMissingSafeHaskellMode = ppr (moduleName (ms_mod sum))+      <+> text "is missing Safe Haskell mode"  -- | Convert a typechecked module to Core hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts@@ -649,7 +673,7 @@             -- save the interface that comes back from checkOldIface.             -- In one-shot mode we don't have the old iface until this             -- point, when checkOldIface reads it from the disk.-            let mb_old_hash = fmap mi_iface_hash mb_checked_iface+            let mb_old_hash = fmap (mi_iface_hash . mi_final_exts) mb_checked_iface              case mb_checked_iface of                 Just iface | not (recompileRequired recomp_reqd) ->@@ -690,7 +714,11 @@ -- Compilers -------------------------------------------------------------- --- Compile Haskell/boot in OneShot mode.+-- | Used by both OneShot and batch mode. Runs the pipeline HsSyn and Core parts+-- of the pipeline.+-- We return a interface if we already had an old one around and recompilation+-- was not needed. Otherwise it will be created during later passes when we+-- run the compilation pipeline. hscIncrementalCompile :: Bool                       -> Maybe TcGblEnv                       -> Maybe Messager@@ -699,9 +727,7 @@                       -> SourceModified                       -> Maybe ModIface                       -> (Int,Int)-                      -- HomeModInfo does not contain linkable, since we haven't-                      -- code-genned yet-                      -> IO (HscStatus, HomeModInfo)+                      -> IO (HscStatus, ModDetails, DynFlags) hscIncrementalCompile always_do_basic_recompilation_check m_tc_result     mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index   = do@@ -730,38 +756,43 @@         -- file on disk was good enough.         Left iface -> do             -- Knot tying!  See Note [Knot-tying typecheckIface]-            hmi <- liftIO . fixIO $ \hmi' -> do+            details <- liftIO . fixIO $ \details' -> do                 let hsc_env' =                         hsc_env {                             hsc_HPT = addToHpt (hsc_HPT hsc_env)-                                        (ms_mod_name mod_summary) hmi'+                                        (ms_mod_name mod_summary) (HomeModInfo iface details' Nothing)                         }                 -- NB: This result is actually not that useful                 -- in one-shot mode, since we're not going to do                 -- any further typechecking.  It's much more useful                 -- in make mode, since this HMI will go into the HPT.                 details <- genModDetails hsc_env' iface-                return HomeModInfo{-                    hm_details = details,-                    hm_iface = iface,-                    hm_linkable = Nothing }-            return (HscUpToDate, hmi)+                return details+            return (HscUpToDate iface, details, dflags)         -- We finished type checking.  (mb_old_hash is the hash of         -- the interface that existed on disk; it's possible we had         -- to retypecheck but the resulting interface is exactly         -- the same.)-        Right (FrontendTypecheck tc_result, mb_old_hash) ->-            finish mod_summary tc_result mb_old_hash+        Right (FrontendTypecheck tc_result, mb_old_hash) -> do+            (status, mb_old_hash) <- finish mod_summary tc_result mb_old_hash+            return (status, mb_old_hash, dflags) --- Runs the post-typechecking frontend (desugar and simplify),--- and then generates and writes out the final interface. We want--- to write the interface AFTER simplification so we can get--- as up-to-date and good unfoldings and other info as possible--- in the interface file.+-- Runs the post-typechecking frontend (desugar and simplify). We want to+-- generate most of the interface as late as possible. This gets us up-to-date+-- and good unfoldings and other info in the interface file.+--+-- We might create a interface right away, in which case we also return the+-- updated HomeModInfo. But we might also need to run the backend first. In the+-- later case Status will be HscRecomp and we return a function from ModIface ->+-- HomeModInfo.+--+-- HscRecomp in turn will carry the information required to compute a interface+-- when passed the result of the code generator. So all this can and is done at+-- the call site of the backend code gen if it is run. finish :: ModSummary        -> TcGblEnv        -> Maybe Fingerprint-       -> Hsc (HscStatus, HomeModInfo)+       -> Hsc (HscStatus, ModDetails) finish summary tc_result mb_old_hash = do   hsc_env <- getHscEnv   let dflags = hsc_dflags hsc_env@@ -769,51 +800,80 @@       hsc_src = ms_hsc_src summary       should_desugar =         ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile+      mk_simple_iface :: Hsc (HscStatus, ModDetails)       mk_simple_iface = do+        (iface, mb_old_iface_hash, details) <- liftIO $+          hscSimpleIface hsc_env tc_result mb_old_hash++        liftIO $ hscMaybeWriteIface dflags iface mb_old_iface_hash (ms_location summary)+         let hsc_status =               case (target, hsc_src) of-                (HscNothing, _) -> HscNotGeneratingCode-                (_, HsBootFile) -> HscUpdateBoot-                (_, HsigFile) -> HscUpdateSig+                (HscNothing, _) -> HscNotGeneratingCode iface+                (_, HsBootFile) -> HscUpdateBoot iface+                (_, HsigFile) -> HscUpdateSig iface                 _ -> panic "finish"-        (iface, no_change, details) <- liftIO $-          hscSimpleIface hsc_env tc_result mb_old_hash-        return (iface, no_change, details, hsc_status)-  (iface, no_change, details, hsc_status) <--    -- we usually desugar even when we are not generating code, otherwise-    -- we would miss errors thrown by the desugaring (see #10600). The only-    -- exceptions are when the Module is Ghc.Prim or when-    -- it is not a HsSrcFile Module.-    if should_desugar-      then do-        desugared_guts0 <- hscDesugar' (ms_location summary) tc_result-        if target == HscNothing-          -- We are not generating code, so we can skip simplification-          -- and generate a simple interface.-          then mk_simple_iface-          else do-            plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)-            desugared_guts <- hscSimplify' plugins desugared_guts0-            (iface, no_change, details, cgguts) <--              liftIO $ hscNormalIface hsc_env desugared_guts mb_old_hash-            return (iface, no_change, details, HscRecomp cgguts summary)-      else mk_simple_iface-  liftIO $ hscMaybeWriteIface dflags iface no_change summary-  return-    ( hsc_status-    , HomeModInfo-      {hm_details = details, hm_iface = iface, hm_linkable = Nothing})+        return (hsc_status, details) -hscMaybeWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()-hscMaybeWriteIface dflags iface no_change summary =+  if should_desugar+    then do+      -- We usually desugar even when we are not generating code, otherwise we+      -- would miss errors thrown by the desugaring (see #10600). The only+      -- exceptions are when the Module is Ghc.Prim or when it is not a+      -- HsSrcFile Module.+      desugared_guts0 <- hscDesugar' (ms_location summary) tc_result+      if target == HscNothing+        -- We are not generating code, so we can skip simplification+        -- and generate a simple interface.+        then mk_simple_iface+        else do+          plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)+          desugared_guts <- hscSimplify' plugins desugared_guts0++          (cg_guts, details) <- {-# SCC "CoreTidy" #-}+              liftIO $ tidyProgram hsc_env desugared_guts++          let !partial_iface =+                {-# SCC "HscMain.mkPartialIface" #-}+                -- This `force` saves 2M residency in test T10370+                -- See Note [Avoiding space leaks in toIface*] for details.+                force (mkPartialIface hsc_env details desugared_guts)++          return ( HscRecomp { hscs_guts = cg_guts,+                               hscs_mod_location = ms_location summary,+                               hscs_partial_iface = partial_iface,+                               hscs_old_iface_hash = mb_old_hash,+                               hscs_iface_dflags = dflags },+                   details )+    else mk_simple_iface+++{-+Note [Writing interface files]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We write interface files in HscMain.hs and DriverPipeline.hs using+hscMaybeWriteIface, but only once per compilation (twice with dynamic-too).++* If a compilation does NOT require (re)compilation of the hard code we call+  hscMaybeWriteIface inside HscMain:finish.+* If we run in One Shot mode and target bytecode we write it in compileOne'+* Otherwise we must be compiling to regular hard code and require recompilation.+  In this case we create the interface file inside RunPhase using the interface+  generator contained inside the HscRecomp status.+-}+hscMaybeWriteIface :: DynFlags -> ModIface -> Maybe Fingerprint -> ModLocation -> IO ()+hscMaybeWriteIface dflags iface old_iface location = do     let force_write_interface = gopt Opt_WriteInterface dflags         write_interface = case hscTarget dflags of                             HscNothing      -> False                             HscInterpreted  -> False                             _               -> True-    in when (write_interface || force_write_interface) $-            hscWriteIface dflags iface no_change summary+        no_change = old_iface == Just (mi_iface_hash (mi_final_exts iface)) +    when (write_interface || force_write_interface) $+          hscWriteIface dflags iface no_change location+ -------------------------------------------------------------- -- NoRecomp handlers --------------------------------------------------------------@@ -942,11 +1002,13 @@               -> return tcg_env'      warns dflags rules = listToBag $ map (warnRules dflags) rules++    warnRules :: DynFlags -> GenLocated SrcSpan (RuleDecl GhcTc) -> ErrMsg     warnRules dflags (L loc (HsRule { rd_name = n })) =         mkPlainWarnMsg dflags loc $             text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$             text "User defined rules are disabled under Safe Haskell"-    warnRules _ (L _ (XRuleDecl _)) = panic "hscCheckSafeImports"+    warnRules _ (L _ (XRuleDecl nec)) = noExtCon nec  -- | Validate that safe imported modules are actually safe.  For modules in the -- HomePackage (the package the module we are compiling in resides) this just@@ -1021,7 +1083,7 @@         | imv_is_safe v1 /= imv_is_safe v2         = do             dflags <- getDynFlags-            throwErrors $ unitBag $ mkPlainErrMsg dflags (imv_span v1)+            throwOneError $ mkPlainErrMsg dflags (imv_span v1)               (text "Module" <+> ppr (imv_name v1) <+>               (text $ "is imported both as a safe and unsafe import!"))         | otherwise@@ -1087,7 +1149,7 @@         iface <- lookup' m         case iface of             -- can't load iface to check trust!-            Nothing -> throwErrors $ unitBag $ mkPlainErrMsg dflags l+            Nothing -> throwOneError $ mkPlainErrMsg dflags l                          $ text "Can't load the interface file for" <+> ppr m                            <> text ", to check that it can be safely imported" @@ -1096,21 +1158,36 @@                 let trust = getSafeMode $ mi_trust iface'                     trust_own_pkg = mi_trust_pkg iface'                     -- check module is trusted-                    safeM = trust `elem` [Sf_Safe, Sf_Trustworthy]+                    safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy]                     -- check package is trusted                     safeP = packageTrusted dflags trust trust_own_pkg m                     -- pkg trust reqs                     pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface'+                    -- warn if Safe module imports Safe-Inferred module.+                    warns = if wopt Opt_WarnInferredSafeImports dflags+                                && safeLanguageOn dflags+                                && trust == Sf_SafeInferred+                                then inferredImportWarn+                                else emptyBag                     -- General errors we throw but Safe errors we log                     errs = case (safeM, safeP) of                         (True, True ) -> emptyBag                         (True, False) -> pkgTrustErr                         (False, _   ) -> modTrustErr                 in do+                    logWarnings warns                     logWarnings errs                     return (trust == Sf_Trustworthy, pkgRs)                  where+                    inferredImportWarn = unitBag+                        $ makeIntoWarning (Reason Opt_WarnInferredSafeImports)+                        $ mkErrMsg dflags l (pkgQual dflags)+                        $ sep+                            [ text "Importing Safe-Inferred module "+                                <> ppr (moduleName m)+                                <> text " from explicitly Safe module"+                            ]                     pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $                         sep [ ppr (moduleName m)                                 <> text ": Can't be safely imported!"@@ -1133,18 +1210,18 @@     packageTrusted dflags _ _ _         | not (packageTrustOn dflags) = True     packageTrusted _ Sf_Safe  False _ = True+    packageTrusted _ Sf_SafeInferred False _ = True     packageTrusted dflags _ _ m         | isHomePkg dflags m = True         | otherwise = trusted $ getPackageDetails dflags (moduleUnitId m)      lookup' :: Module -> Hsc (Maybe ModIface)     lookup' m = do-        dflags <- getDynFlags         hsc_env <- getHscEnv         hsc_eps <- liftIO $ hscEPS hsc_env         let pkgIfaceT = eps_PIT hsc_eps             homePkgT  = hsc_HPT hsc_env-            iface     = lookupIfaceByModule dflags homePkgT pkgIfaceT m+            iface     = lookupIfaceByModule homePkgT pkgIfaceT m         -- the 'lookupIfaceByModule' method will always fail when calling from GHCi         -- as the compiler hasn't filled in the various module tables         -- so we need to call 'getModuleInterface' to load from disk@@ -1254,82 +1331,84 @@ -- Interface generators -------------------------------------------------------------- +-- | Generate a striped down interface file, e.g. for boot files or when ghci+-- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc] hscSimpleIface :: HscEnv                -> TcGblEnv                -> Maybe Fingerprint-               -> IO (ModIface, Bool, ModDetails)+               -> IO (ModIface, Maybe Fingerprint, ModDetails) hscSimpleIface hsc_env tc_result mb_old_iface     = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface  hscSimpleIface' :: TcGblEnv                 -> Maybe Fingerprint-                -> Hsc (ModIface, Bool, ModDetails)+                -> Hsc (ModIface, Maybe Fingerprint, ModDetails) hscSimpleIface' tc_result mb_old_iface = do     hsc_env   <- getHscEnv     details   <- liftIO $ mkBootModDetailsTc hsc_env tc_result     safe_mode <- hscGetSafeMode tc_result-    (new_iface, no_change)+    new_iface         <- {-# SCC "MkFinalIface" #-}            liftIO $-               mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result+               mkIfaceTc hsc_env safe_mode details tc_result     -- And the answer is ...     liftIO $ dumpIfaceStats hsc_env-    return (new_iface, no_change, details)--hscNormalIface :: HscEnv-               -> ModGuts-               -> Maybe Fingerprint-               -> IO (ModIface, Bool, ModDetails, CgGuts)-hscNormalIface hsc_env simpl_result mb_old_iface =-    runHsc hsc_env $ hscNormalIface' simpl_result mb_old_iface+    return (new_iface, mb_old_iface, details) -hscNormalIface' :: ModGuts-                -> Maybe Fingerprint-                -> Hsc (ModIface, Bool, ModDetails, CgGuts)-hscNormalIface' simpl_result mb_old_iface = do-    hsc_env <- getHscEnv-    (cg_guts, details) <- {-# SCC "CoreTidy" #-}-                          liftIO $ tidyProgram hsc_env simpl_result+--------------------------------------------------------------+-- BackEnd combinators+--------------------------------------------------------------+{-+Note [Interface filename extensions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -    -- BUILD THE NEW ModIface and ModDetails-    --  and emit external core if necessary-    -- This has to happen *after* code gen so that the back-end-    -- info has been set. Not yet clear if it matters waiting-    -- until after code output-    (new_iface, no_change)-        <- {-# SCC "MkFinalIface" #-}-           liftIO $-               mkIface hsc_env mb_old_iface details simpl_result+ModLocation only contains the base names, however when generating dynamic files+the actual extension might differ from the default. -    liftIO $ dumpIfaceStats hsc_env+So we only load the base name from ModLocation and replace the actual extension+according to the information in DynFlags. -    -- Return the prepared code.-    return (new_iface, no_change, details, cg_guts)+If we generate a interface file right after running the core pipeline we will+have set -dynamic-too and potentially generate both interface files at the same+time. ------------------------------------------------------------------ BackEnd combinators---------------------------------------------------------------+If we generate a interface file after running the backend then dynamic-too won't+be set, however then the extension will be contained in the dynflags instead so+things still work out fine.+-} -hscWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()-hscWriteIface dflags iface no_change mod_summary = do-    let ifaceFile = ml_hi_file (ms_location mod_summary)+hscWriteIface :: DynFlags -> ModIface -> Bool -> ModLocation -> IO ()+hscWriteIface dflags iface no_change mod_location = do+    -- mod_location only contains the base name, so we rebuild the+    -- correct file extension from the dynflags.+    let ifaceBaseFile = ml_hi_file mod_location     unless no_change $-        {-# SCC "writeIface" #-}-        writeIfaceFile dflags ifaceFile iface+        let ifaceFile = buildIfName ifaceBaseFile (hiSuf dflags)+        in  {-# SCC "writeIface" #-}+            writeIfaceFile dflags ifaceFile iface     whenGeneratingDynamicToo dflags $ do         -- TODO: We should do a no_change check for the dynamic         --       interface file too-        -- TODO: Should handle the dynamic hi filename properly-        let dynIfaceFile = replaceExtension ifaceFile (dynHiSuf dflags)-            dynIfaceFile' = addBootSuffix_maybe (mi_boot iface) dynIfaceFile-            dynDflags = dynamicTooMkDynamicDynFlags dflags-        writeIfaceFile dynDflags dynIfaceFile' iface+        -- When we generate iface files after core+        let dynDflags = dynamicTooMkDynamicDynFlags dflags+            -- dynDflags will have set hiSuf correctly.+            dynIfaceFile = buildIfName ifaceBaseFile (hiSuf dynDflags) +        writeIfaceFile dynDflags dynIfaceFile iface+  where+    buildIfName :: String -> String -> String+    buildIfName baseName suffix+      | Just name <- outputHi dflags+      = name+      | otherwise+      = let with_hi = replaceExtension baseName suffix+        in  addBootSuffix_maybe (mi_boot iface) with_hi+ -- | Compile to hard-code.-hscGenHardCode :: HscEnv -> CgGuts -> ModSummary -> FilePath+hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath                -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)])                -- ^ @Just f@ <=> _stub.c is f-hscGenHardCode hsc_env cgguts mod_summary output_filename = do+hscGenHardCode hsc_env cgguts location output_filename = do         let CgGuts{ -- This is the last use of the ModGuts in a compilation.                     -- From now on, we just use the bits we need.                     cg_module   = this_mod,@@ -1340,7 +1419,6 @@                     cg_dep_pkgs = dependencies,                     cg_hpc_info = hpc_info } = cgguts             dflags = hsc_dflags hsc_env-            location = ms_location mod_summary             data_tycons = filter isDataTyCon tycons             -- cg_tycons includes newtypes, for the benefit of External Core,             -- but we don't generate any code for newtypes@@ -1368,10 +1446,10 @@         -- top-level function, so showPass isn't very useful here.         -- Hence we have one showPass for the whole backend, the         -- next showPass after this will be "Assembler".-        withTiming (pure dflags)+        withTiming dflags                    (text "CodeGen"<+>brackets (ppr this_mod))                    (const ()) $ do-            cmms <- {-# SCC "StgCmm" #-}+            cmms <- {-# SCC "StgToCmm" #-}                             doCodeGen hsc_env this_mod data_tycons                                 cost_centre_info                                 stg_binds hpc_info@@ -1385,7 +1463,7 @@                             return a                 rawcmms1 = Stream.mapM dump rawcmms0 -            (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps)+            (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, ())                 <- {-# SCC "codeOutput" #-}                   codeOutput dflags this_mod output_filename location                   foreign_stubs foreign_files dependencies rawcmms1@@ -1394,9 +1472,9 @@  hscInteractive :: HscEnv                -> CgGuts-               -> ModSummary+               -> ModLocation                -> IO (Maybe FilePath, CompiledByteCode, [SptEntry])-hscInteractive hsc_env cgguts mod_summary = do+hscInteractive hsc_env cgguts location = do     let dflags = hsc_dflags hsc_env     let CgGuts{ -- This is the last use of the ModGuts in a compilation.                 -- From now on, we just use the bits we need.@@ -1407,7 +1485,6 @@                cg_modBreaks = mod_breaks,                cg_spt_entries = spt_entries } = cgguts -        location = ms_location mod_summary         data_tycons = filter isDataTyCon tycons         -- cg_tycons includes newtypes, for the benefit of External Core,         -- but we don't generate any code for newtypes@@ -1431,7 +1508,7 @@     let dflags = hsc_dflags hsc_env     cmm <- ioMsgMaybe $ parseCmmFile dflags filename     liftIO $ do-        dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose "Parsed Cmm" (ppr cmm)+        dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" (ppr cmm)         let -- Make up a module name to give the NCG. We can't pass bottom here             -- lest we reproduce #11784.             mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename@@ -1463,9 +1540,10 @@     let dflags = hsc_dflags hsc_env      let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds+     let cmm_stream :: Stream IO CmmGroup ()-        cmm_stream = {-# SCC "StgCmm" #-}-            StgCmm.codeGen dflags this_mod data_tycons+        cmm_stream = {-# SCC "StgToCmm" #-}+            StgToCmm.codeGen dflags this_mod data_tycons                            cost_centre_info stg_binds_w_fvs hpc_info          -- codegen consumes a stream of CmmGroup, and produces a new@@ -1479,31 +1557,11 @@          ppr_stream1 = Stream.mapM dump1 cmm_stream -    -- We are building a single SRT for the entire module, so-    -- we must thread it through all the procedures as we cps-convert them.-    us <- mkSplitUniqSupply 'S'--    -- When splitting, we generate one SRT per split chunk, otherwise-    -- we generate one SRT for the whole module.-    let-     pipeline_stream-      | gopt Opt_SplitObjs dflags || gopt Opt_SplitSections dflags ||-        osSubsectionsViaSymbols (platformOS (targetPlatform dflags))-        = {-# SCC "cmmPipeline" #-}-          let run_pipeline us cmmgroup = do-                (_topSRT, cmmgroup) <--                  cmmPipeline hsc_env (emptySRT this_mod) cmmgroup-                return (us, cmmgroup)--          in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1-                return ()--      | otherwise-        = {-# SCC "cmmPipeline" #-}-          let run_pipeline = cmmPipeline hsc_env-          in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1+        pipeline_stream+           = {-# SCC "cmmPipeline" #-}+             let run_pipeline = cmmPipeline hsc_env+             in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1 -    let         dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm                         "Output Cmm" (ppr a)                      return a@@ -1750,7 +1808,7 @@ hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do     hsc_env <- getHscEnv     ty <- hscParseType str-    ioMsgMaybe $ tcRnType hsc_env normalise ty+    ioMsgMaybe $ tcRnType hsc_env DefaultFlexi normalise ty  hscParseExpr :: String -> Hsc (LHsExpr GhcPs) hscParseExpr expr = do@@ -1758,7 +1816,7 @@   maybe_stmt <- hscParseStmt expr   case maybe_stmt of     Just (L _ (BodyStmt _ expr _ _)) -> return expr-    _ -> throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan+    _ -> throwOneError $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan       (text "not an expression:" <+> quotes (text expr))  hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))@@ -1783,7 +1841,7 @@ hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int                           -> Lexer.P thing -> String -> Hsc thing hscParseThingWithLocation source linenumber parser str-  = withTiming getDynFlags+  = withTimingD                (text "Parser [source]")                (const ()) $ {-# SCC "Parser" #-} do     dflags <- getDynFlags@@ -1792,11 +1850,8 @@         loc = mkRealSrcLoc (fsLit source) linenumber 1      case unP parser (mkPState dflags buf loc) of-        PFailed warnFn span err -> do-            logWarningsReportErrors (warnFn dflags)-            handleWarnings-            let msg = mkPlainErrMsg dflags span err-            throwErrors $ unitBag msg+        PFailed pst -> do+            handleWarningsThrowErrors (getMessages pst dflags)          POk pst thing -> do             logWarningsReportErrors (getMessages pst dflags)
compiler/main/HscStats.hs view
@@ -13,7 +13,7 @@ import GhcPrelude  import Bag-import HsSyn+import GHC.Hs import Outputable import SrcLoc import Util@@ -122,13 +122,14 @@     import_info (dL->L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual                                      , ideclAs = as, ideclHiding = spec }))         = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec)-    import_info (dL->L _ (XImportDecl _)) = panic "import_info"+    import_info (dL->L _ (XImportDecl nec)) = noExtCon nec     import_info _ = panic " import_info: Impossible Match"                              -- due to #15884 -    safe_info = qual_info-    qual_info False  = 0-    qual_info True   = 1+    safe_info False = 0+    safe_info True = 1+    qual_info NotQualified = 0+    qual_info _  = 1     as_info Nothing  = 0     as_info (Just _) = 1     spec_info Nothing           = (0,0,0,0,1,0,0)@@ -162,8 +163,8 @@                    ss, is, length ats, length adts)       where         methods = map unLoc $ bagToList inst_meths-    inst_info (ClsInstD _ (XClsInstDecl _)) = panic "inst_info"-    inst_info (XInstDecl _)                 = panic "inst_info"+    inst_info (ClsInstD _ (XClsInstDecl nec)) = noExtCon nec+    inst_info (XInstDecl nec)                 = noExtCon nec      -- TODO: use Sum monoid     addpr :: (Int,Int,Int) -> Int
compiler/main/InteractiveEval.hs view
@@ -30,6 +30,8 @@         exprType,         typeKind,         parseName,+        parseInstanceHead,+        getInstancesForType,         getDocs,         GetDocsFailure(..),         showModule,@@ -40,7 +42,7 @@         Term(..), obtainTermFromId, obtainTermFromVal, reconstructType         ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -51,7 +53,7 @@ import GHCi.RemoteTypes import GhcMonad import HscMain-import HsSyn+import GHC.Hs import HscTypes import InstEnv import IfaceEnv   ( newInteractiveBinder )@@ -60,7 +62,10 @@ import TyCon import Type             hiding( typeKind ) import RepType-import TcType           hiding( typeKind )+import TcType+import Constraint+import TcOrigin+import Predicate import Var import Id import Name             hiding ( varName )@@ -102,6 +107,19 @@ import Data.Array import Exception +import TcRnDriver ( runTcInteractive, tcRnType, loadUnqualIfaces )+import TcHsSyn          ( ZonkFlexi (SkolemiseFlexi) )++import TcEnv (tcGetInstEnvs)++import Inst (instDFunType)+import TcSimplify (solveWanteds)+import TcRnMonad+import TcEvidence+import Data.Bifunctor (second)++import TcSMonad (runTcS)+ -- ----------------------------------------------------------------------------- -- running a statement interactively @@ -249,7 +267,7 @@ OccNames that users can't write, to avoid the possibility of name clashes (in linker symbols).  That gives a convenient way to suppress them. The relevant predicate is OccName.isDerivedOccName.-See Trac #11051 for more background and examples.+See #11051 for more background and examples. -}  withVirtualCWD :: GhcMonad m => m a -> m a@@ -357,7 +375,8 @@     = do hsc_env <- getSession          let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids              final_names = map getName final_ids-         liftIO $ Linker.extendLinkEnv (zip final_names hvals)+             dl = hsc_dynLinker hsc_env+         liftIO $ Linker.extendLinkEnv dl (zip final_names hvals)          hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}          setSession hsc_env'          return (ExecComplete (Right final_names) allocs)@@ -396,7 +415,8 @@             new_names = [ n | thing <- ic_tythings ic                             , let n = getName thing                             , not (n `elem` old_names) ]-        liftIO $ Linker.deleteFromLinkEnv new_names+            dl        = hsc_dynLinker hsc_env+        liftIO $ Linker.deleteFromLinkEnv dl new_names          case r of           Resume { resumeStmt = expr, resumeContext = fhv@@ -490,8 +510,9 @@         ictxt0 = hsc_IC hsc_env        ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id]+       dl     = hsc_dynLinker hsc_env    ---   Linker.extendLinkEnv [(exn_name, apStack)]+   Linker.extendLinkEnv dl [(exn_name, apStack)]    return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>")  -- Just case: we stopped at a breakpoint, we have information about the location@@ -546,10 +567,11 @@        ictxt0 = hsc_IC hsc_env        ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids        names  = map idName new_ids+       dl     = hsc_dynLinker hsc_env     let fhvs = catMaybes mb_hValues-   Linker.extendLinkEnv (zip names fhvs)-   when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)]+   Linker.extendLinkEnv dl (zip names fhvs)+   when result_ok $ Linker.extendLinkEnv dl [(result_name, apStack_fhv)]    hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }    return (hsc_env1, if result_ok then result_name:names else names, span, decl)   where@@ -801,7 +823,7 @@ -- Filter the instances by the ones whose tycons (or clases resp) -- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many! -- The exact choice of which ones to show, and which to hide, is a judgement call.---      (see Trac #1581)+--      (see #1581) getInfo :: GhcMonad m => Bool -> Name         -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst], SDoc)) getInfo allInfo name@@ -845,7 +867,7 @@       ic = hsc_IC hsc_env       gbl_rdrenv = ic_rn_gbl_env ic       gbl_names = concatMap greRdrNames $ globalRdrEnvElts gbl_rdrenv-  -- Exclude internally generated names; see e.g. Trac #11328+  -- Exclude internally generated names; see e.g. #11328   return (filter (not . isDerivedOccName . rdrNameOcc) gbl_names)  @@ -861,14 +883,14 @@ isStmt dflags stmt =   case parseThing Parser.parseStmt dflags stmt of     Lexer.POk _ _ -> True-    Lexer.PFailed _ _ _ -> False+    Lexer.PFailed _ -> False  -- | Returns @True@ if passed string has an import declaration. hasImport :: DynFlags -> String -> Bool hasImport dflags stmt =   case parseThing Parser.parseModule dflags stmt of     Lexer.POk _ thing -> hasImports thing-    Lexer.PFailed _ _ _ -> False+    Lexer.PFailed _ -> False   where     hasImports = not . null . hsmodImports . unLoc @@ -877,7 +899,7 @@ isImport dflags stmt =   case parseThing Parser.parseImport dflags stmt of     Lexer.POk _ _ -> True-    Lexer.PFailed _ _ _ -> False+    Lexer.PFailed _ -> False  -- | Returns @True@ if passed string is a declaration but __/not a splice/__. isDecl :: DynFlags -> String -> Bool@@ -887,7 +909,7 @@       case unLoc thing of         SpliceD _ _ -> False         _ -> True-    Lexer.PFailed _ _ _ -> False+    Lexer.PFailed _ -> False  parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing parseThing parser dflags stmt = do@@ -978,6 +1000,163 @@ typeKind normalise str = withSession $ \hsc_env -> do    liftIO $ hscKcType hsc_env normalise str +-- ----------------------------------------------------------------------------+-- Getting the class instances for a type++{-+  Note [Querying instances for a type]++  Here is the implementation of GHC proposal 41.+  (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0041-ghci-instances.rst)++  The objective is to take a query string representing a (partial) type, and+  report all the class single-parameter class instances available to that type.+  Extending this feature to multi-parameter typeclasses is left as future work.++  The general outline of how we solve this is:++  1. Parse the type, leaving skolems in the place of type-holes.+  2. For every class, get a list of all instances that match with the query type.+  3. For every matching instance, ask GHC for the context the instance dictionary needs.+  4. Format and present the results, substituting our query into the instance+     and simplifying the context.++  For example, given the query "Maybe Int", we want to return:++  instance Show (Maybe Int)+  instance Read (Maybe Int)+  instance Eq   (Maybe Int)+  ....++  [Holes in queries]++  Often times we want to know what instances are available for a polymorphic type,+  like `Maybe a`, and we'd like to return instances such as:++  instance Show a => Show (Maybe a)+  ....++  These queries are expressed using type holes, so instead of `Maybe a` the user writes+  `Maybe _`, we parse the type and during zonking, we skolemise it, replacing the holes+  with (un-named) type variables.++  When zonking the type holes we have two real choices: replace them with Any or replace+  them with skolem typevars. Using skolem type variables ensures that the output is more+  intuitive to end users, and there is no difference in the results between Any and skolems.++-}++-- Find all instances that match a provided type+getInstancesForType :: GhcMonad m => Type -> m [ClsInst]+getInstancesForType ty = withSession $ \hsc_env -> do+  liftIO $ runInteractiveHsc hsc_env $ do+    ioMsgMaybe $ runTcInteractive hsc_env $ do+      -- Bring class and instances from unqualified modules into scope, this fixes #16793.+      loadUnqualIfaces hsc_env (hsc_IC hsc_env)+      matches <- findMatchingInstances ty+      fmap catMaybes . forM matches $ uncurry checkForExistence++-- Parse a type string and turn any holes into skolems+parseInstanceHead :: GhcMonad m => String -> m Type+parseInstanceHead str = withSession $ \hsc_env0 -> do+  (ty, _) <- liftIO $ runInteractiveHsc hsc_env0 $ do+    hsc_env <- getHscEnv+    ty <- hscParseType str+    ioMsgMaybe $ tcRnType hsc_env SkolemiseFlexi True ty++  return ty++-- Get all the constraints required of a dictionary binding+getDictionaryBindings :: PredType -> TcM WantedConstraints+getDictionaryBindings theta = do+  dictName <- newName (mkDictOcc (mkVarOcc "magic"))+  let dict_var = mkVanillaGlobal dictName theta+  loc <- getCtLocM (GivenOrigin UnkSkol) Nothing+  let wCs = mkSimpleWC [CtDerived+          { ctev_pred = varType dict_var+          , ctev_loc = loc+          }]++  return wCs++{-+  When we've found an instance that a query matches against, we still need to+  check that all the instance's constraints are satisfiable. checkForExistence+  creates an instance dictionary and verifies that any unsolved constraints+  mention a type-hole, meaning it is blocked on an unknown.++  If the instance satisfies this condition, then we return it with the query+  substituted into the instance and all constraints simplified, for example given:++  instance D a => C (MyType a b) where++  and the query `MyType _ String`++  the unsolved constraints will be [D _] so we apply the substitution:++  { a -> _; b -> String}++  and return the instance:++  instance D _ => C (MyType _ String)++-}++checkForExistence :: ClsInst -> [DFunInstType] -> TcM (Maybe ClsInst)+checkForExistence res mb_inst_tys = do+  (tys, thetas) <- instDFunType (is_dfun res) mb_inst_tys++  wanteds <- forM thetas getDictionaryBindings+  (residuals, _) <- second evBindMapBinds <$> runTcS (solveWanteds (unionsWC wanteds))++  let all_residual_constraints = bagToList $ wc_simple residuals+  let preds = map ctPred all_residual_constraints+  if all isSatisfiablePred preds && (null $ wc_impl residuals)+  then return . Just $ substInstArgs tys preds res+  else return Nothing++  where++  -- Stricter version of isTyVarClassPred that requires all TyConApps to have at least+  -- one argument or for the head to be a TyVar. The reason is that we want to ensure+  -- that all residual constraints mention a type-hole somewhere in the constraint,+  -- meaning that with the correct choice of a concrete type it could be possible for+  -- the constraint to be discharged.+  isSatisfiablePred :: PredType -> Bool+  isSatisfiablePred ty = case getClassPredTys_maybe ty of+      Just (_, tys@(_:_)) -> all isTyVarTy tys+      _                   -> isTyVarTy ty++  empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType (idType $ is_dfun res)))++  {- Create a ClsInst with instantiated arguments and constraints.++     The thetas are the list of constraints that couldn't be solved because+     they mention a type-hole.+  -}+  substInstArgs ::  [Type] -> [PredType] -> ClsInst -> ClsInst+  substInstArgs tys thetas inst = let+      subst = foldl' (\a b -> uncurry (extendTvSubstAndInScope a) b) empty_subst (zip dfun_tvs tys)+      -- Build instance head with arguments substituted in+      tau   = mkClassPred cls (substTheta subst args)+      -- Constrain the instance with any residual constraints+      phi   = mkPhiTy thetas tau+      sigma = mkForAllTys (map (\v -> Bndr v Inferred) dfun_tvs) phi++    in inst { is_dfun = (is_dfun inst) { varType = sigma }}+    where+    (dfun_tvs, _, cls, args) = instanceSig inst++-- Find instances where the head unifies with the provided type+findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])]+findMatchingInstances ty = do+  ies@(InstEnvs {ie_global = ie_global, ie_local = ie_local}) <- tcGetInstEnvs+  let allClasses = instEnvClasses ie_global ++ instEnvClasses ie_local++  concat <$> mapM (\cls -> do+    let (matches, _, _) = lookupInstEnv True ies cls [ty]+    return matches) allClasses+ ----------------------------------------------------------------------------- -- Compile an expression, run it, and deliver the result @@ -1009,8 +1188,8 @@   -- create a new binding.   let expr_fs = fsLit "_compileParsedExpr"       expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc-      let_stmt = L loc . LetStmt noExt . L loc . (HsValBinds noExt) $-        ValBinds noExt+      let_stmt = L loc . LetStmt noExtField . L loc . (HsValBinds noExtField) $+        ValBinds noExtField                      (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) []    pstmt <- liftIO $ hscParsedStmt hsc_env let_stmt@@ -1038,7 +1217,7 @@   parsed_expr <- parseExpr expr   -- > Data.Dynamic.toDyn expr   let loc = getLoc parsed_expr-      to_dyn_expr = mkHsApp (L loc . HsVar noExt . L loc $ getRdrName toDynName)+      to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L loc $ getRdrName toDynName)                             parsed_expr   hval <- compileParsedExpr to_dyn_expr   return (unsafeCoerce# hval :: Dynamic)
compiler/main/PprTyThing.hs view
@@ -17,19 +17,18 @@         pprFamInst   ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude -import Type    ( ArgFlag(..), TyThing(..), mkTyVarBinders, pprUserForAll )+import Type    ( Type, ArgFlag(..), TyThing(..), mkTyVarBinders, tidyOpenType ) import IfaceSyn ( ShowSub(..), ShowHowMuch(..), AltPpr(..)   , showToHeader, pprIfaceDecl ) import CoAxiom ( coAxiomTyCon ) import HscTypes( tyThingParent_maybe ) import MkIface ( tyThingToIfaceDecl )-import Type ( tidyOpenType ) import FamInstEnv( FamInst(..), FamFlavor(..) )-import Type( Type, pprTypeApp, pprSigmaType )+import TyCoPpr ( pprUserForAll, pprTypeApp, pprSigmaType ) import Name import VarEnv( emptyTidyEnv ) import Outputable
compiler/main/StaticPtrTable.hs view
@@ -135,7 +135,7 @@ import Module import Name import Outputable-import Platform+import GHC.Platform import PrelNames import TcEnv (lookupGlobal) import Type@@ -233,9 +233,10 @@      -- Choose either 'Word64#' or 'Word#' to represent the arguments of the     -- 'Fingerprint' data constructor.-    mkWord64LitWordRep dflags-      | platformWordSize (targetPlatform dflags) < 8 = mkWord64LitWord64-      | otherwise = mkWordLit dflags . toInteger+    mkWord64LitWordRep dflags =+      case platformWordSize (targetPlatform dflags) of+        PW4 -> mkWord64LitWord64+        PW8 -> mkWordLit dflags . toInteger      lookupIdHscEnv :: Name -> IO Id     lookupIdHscEnv n = lookupTypeHscEnv hsc_env n >>=
compiler/main/SysTools.hs view
@@ -13,7 +13,7 @@ module SysTools (         -- * Initialisation         initSysTools,-        initLlvmConfig,+        lazyInitLlvmConfig,          -- * Interface to system tools         module SysTools.Tasks,@@ -36,27 +36,28 @@         getFrameworkOpts  ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude +import GHC.Settings+ import Module import Packages-import Config import Outputable import ErrUtils-import Platform-import Util+import GHC.Platform import DynFlags-import Fingerprint +import Control.Monad.Trans.Except (runExceptT) import System.FilePath import System.IO-import System.Directory+import System.IO.Unsafe (unsafeInterleaveIO) import SysTools.ExtraObj import SysTools.Info import SysTools.Tasks import SysTools.BaseDir+import SysTools.Settings  {- Note [How GHC finds toolchain utilities]@@ -110,13 +111,34 @@ ************************************************************************ -} -initLlvmConfig :: String+-- Note [LLVM configuration]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The `llvm-targets` and `llvm-passes` files are shipped with GHC and contain+-- information needed by the LLVM backend to invoke `llc` and `opt`.+-- Specifically:+--+--  * llvm-targets maps autoconf host triples to the corresponding LLVM+--    `data-layout` declarations. This information is extracted from clang using+--    the script in utils/llvm-targets/gen-data-layout.sh and should be updated+--    whenever we target a new version of LLVM.+--+--  * llvm-passes maps GHC optimization levels to sets of LLVM optimization+--    flags that GHC should pass to `opt`.+--+-- This information is contained in files rather the GHC source to allow users+-- to add new targets to GHC without having to recompile the compiler.+--+-- Since this information is only needed by the LLVM backend we load it lazily+-- with unsafeInterleaveIO. Consequently it is important that we lazily pattern+-- match on LlvmConfig until we actually need its contents.++lazyInitLlvmConfig :: String                -> IO LlvmConfig-initLlvmConfig top_dir-  = do+lazyInitLlvmConfig top_dir+  = unsafeInterleaveIO $ do    -- see Note [LLVM configuration]       targets <- readAndParse "llvm-targets" mkLlvmTarget       passes <- readAndParse "llvm-passes" id-      return (targets, passes)+      return $ LlvmConfig { llvmTargets = targets, llvmPasses = passes }   where     readAndParse name builder =       do let llvmConfigFile = top_dir </> name@@ -134,201 +156,16 @@                                 --      (a) the system programs                                 --      (b) the package-config file                                 --      (c) the GHC usage message-initSysTools top_dir-  = do       -- see Note [topdir: How GHC finds its files]-             -- NB: top_dir is assumed to be in standard Unix-             -- format, '/' separated-       mtool_dir <- findToolDir top_dir-             -- see Note [tooldir: How GHC finds mingw and perl on Windows]--       let installed :: FilePath -> FilePath-           installed file = top_dir </> file-           libexec :: FilePath -> FilePath-           libexec file = top_dir </> "bin" </> file-           settingsFile = installed "settings"-           platformConstantsFile = installed "platformConstants"--       settingsStr <- readFile settingsFile-       platformConstantsStr <- readFile platformConstantsFile-       mySettings <- case maybeReadFuzzy settingsStr of-                     Just s ->-                         return s-                     Nothing ->-                         pgmError ("Can't parse " ++ show settingsFile)-       platformConstants <- case maybeReadFuzzy platformConstantsStr of-                            Just s ->-                                return s-                            Nothing ->-                                pgmError ("Can't parse " ++-                                          show platformConstantsFile)-       let getSetting key = case lookup key mySettings of-                            Just xs -> return $ expandTopDir top_dir xs-                            Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)-           getToolSetting key = expandToolDir mtool_dir <$> getSetting key-           getBooleanSetting key = case lookup key mySettings of-                                   Just "YES" -> return True-                                   Just "NO" -> return False-                                   Just xs -> pgmError ("Bad value for " ++ show key ++ ": " ++ show xs)-                                   Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)-           readSetting key = case lookup key mySettings of-                             Just xs ->-                                 case maybeRead xs of-                                 Just v -> return v-                                 Nothing -> pgmError ("Failed to read " ++ show key ++ " value " ++ show xs)-                             Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)-       crossCompiling <- getBooleanSetting "cross compiling"-       targetArch <- readSetting "target arch"-       targetOS <- readSetting "target os"-       targetWordSize <- readSetting "target word size"-       targetUnregisterised <- getBooleanSetting "Unregisterised"-       targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack"-       targetHasIdentDirective <- readSetting "target has .ident directive"-       targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols"-       myExtraGccViaCFlags <- getSetting "GCC extra via C opts"-       -- On Windows, mingw is distributed with GHC,-       -- so we look in TopDir/../mingw/bin,-       -- as well as TopDir/../../mingw/bin for hadrian.-       -- It would perhaps be nice to be able to override this-       -- with the settings file, but it would be a little fiddly-       -- to make that possible, so for now you can't.-       gcc_prog <- getToolSetting "C compiler command"-       gcc_args_str <- getSetting "C compiler flags"-       gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie"-       cpp_prog <- getToolSetting "Haskell CPP command"-       cpp_args_str <- getSetting "Haskell CPP flags"-       let unreg_gcc_args = if targetUnregisterised-                            then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]-                            else []-           -- TABLES_NEXT_TO_CODE affects the info table layout.-           tntc_gcc_args-            | mkTablesNextToCode targetUnregisterised-               = ["-DTABLES_NEXT_TO_CODE"]-            | otherwise = []-           cpp_args= map Option (words cpp_args_str)-           gcc_args = map Option (words gcc_args_str-                               ++ unreg_gcc_args-                               ++ tntc_gcc_args)-       ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"-       ldSupportsBuildId       <- getBooleanSetting "ld supports build-id"-       ldSupportsFilelist      <- getBooleanSetting "ld supports filelist"-       ldIsGnuLd               <- getBooleanSetting "ld is GNU ld"-       perl_path <- getToolSetting "perl command"--       let pkgconfig_path = installed "package.conf.d"-           ghc_usage_msg_path  = installed "ghc-usage.txt"-           ghci_usage_msg_path = installed "ghci-usage.txt"--             -- For all systems, unlit, split, mangle are GHC utilities-             -- architecture-specific stuff is done when building Config.hs-           unlit_path = libexec cGHC_UNLIT_PGM--             -- split is a Perl script-           split_script  = libexec cGHC_SPLIT_PGM--       windres_path <- getToolSetting "windres command"-       libtool_path <- getToolSetting "libtool command"-       ar_path <- getToolSetting "ar command"-       ranlib_path <- getToolSetting "ranlib command"--       tmpdir <- getTemporaryDirectory--       touch_path <- getToolSetting "touch command"--       let -- On Win32 we don't want to rely on #!/bin/perl, so we prepend-           -- a call to Perl to get the invocation of split.-           -- On Unix, scripts are invoked using the '#!' method.  Binary-           -- installations of GHC on Unix place the correct line on the-           -- front of the script at installation time, so we don't want-           -- to wire-in our knowledge of $(PERL) on the host system here.-           (split_prog,  split_args)-             | isWindowsHost = (perl_path,    [Option split_script])-             | otherwise     = (split_script, [])-       mkdll_prog <- getToolSetting "dllwrap command"-       let mkdll_args = []--       -- cpp is derived from gcc on all platforms-       -- HACK, see setPgmP below. We keep 'words' here to remember to fix-       -- Config.hs one day.---       -- Other things being equal, as and ld are simply gcc-       gcc_link_args_str <- getSetting "C compiler link flags"-       let   as_prog  = gcc_prog-             as_args  = gcc_args-             ld_prog  = gcc_prog-             ld_args  = gcc_args ++ map Option (words gcc_link_args_str)--       -- We just assume on command line-       lc_prog <- getSetting "LLVM llc command"-       lo_prog <- getSetting "LLVM opt command"-       lcc_prog <- getSetting "LLVM clang command"--       let iserv_prog = libexec "ghc-iserv"--       let platform = Platform {-                          platformArch = targetArch,-                          platformOS   = targetOS,-                          platformWordSize = targetWordSize,-                          platformUnregisterised = targetUnregisterised,-                          platformHasGnuNonexecStack = targetHasGnuNonexecStack,-                          platformHasIdentDirective = targetHasIdentDirective,-                          platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols,-                          platformIsCrossCompiling = crossCompiling-                      }--       return $ Settings {-                    sTargetPlatform = platform,-                    sTmpDir         = normalise tmpdir,-                    sGhcUsagePath   = ghc_usage_msg_path,-                    sGhciUsagePath  = ghci_usage_msg_path,-                    sToolDir        = mtool_dir,-                    sTopDir         = top_dir,-                    sRawSettings    = mySettings,-                    sExtraGccViaCFlags = words myExtraGccViaCFlags,-                    sSystemPackageConfig = pkgconfig_path,-                    sLdSupportsCompactUnwind = ldSupportsCompactUnwind,-                    sLdSupportsBuildId       = ldSupportsBuildId,-                    sLdSupportsFilelist      = ldSupportsFilelist,-                    sLdIsGnuLd               = ldIsGnuLd,-                    sGccSupportsNoPie        = gccSupportsNoPie,-                    sProgramName             = "ghc",-                    sProjectVersion          = cProjectVersion,-                    sPgm_L   = unlit_path,-                    sPgm_P   = (cpp_prog, cpp_args),-                    sPgm_F   = "",-                    sPgm_c   = (gcc_prog, gcc_args),-                    sPgm_s   = (split_prog,split_args),-                    sPgm_a   = (as_prog, as_args),-                    sPgm_l   = (ld_prog, ld_args),-                    sPgm_dll = (mkdll_prog,mkdll_args),-                    sPgm_T   = touch_path,-                    sPgm_windres = windres_path,-                    sPgm_libtool = libtool_path,-                    sPgm_ar = ar_path,-                    sPgm_ranlib = ranlib_path,-                    sPgm_lo  = (lo_prog,[]),-                    sPgm_lc  = (lc_prog,[]),-                    sPgm_lcc = (lcc_prog,[]),-                    sPgm_i   = iserv_prog,-                    sOpt_L       = [],-                    sOpt_P       = [],-                    sOpt_P_fingerprint = fingerprint0,-                    sOpt_F       = [],-                    sOpt_c       = [],-                    sOpt_a       = [],-                    sOpt_l       = [],-                    sOpt_windres = [],-                    sOpt_lcc     = [],-                    sOpt_lo      = [],-                    sOpt_lc      = [],-                    sOpt_i       = [],-                    sPlatformConstants = platformConstants-             }-+initSysTools top_dir = do+  res <- runExceptT $ initSettings top_dir+  case res of+    Right a -> pure a+    Left (SettingsError_MissingData msg) -> pgmError msg+    Left (SettingsError_BadData msg) -> pgmError msg  {- Note [Windows stack usage] -See: Trac #8870 (and #8834 for related info) and #12186+See: #8870 (and #8834 for related info) and #12186  On Windows, occasionally we need to grow the stack. In order to do this, we would normally just bump the stack pointer - but there's a@@ -398,10 +235,12 @@         -- against libHSrts, then both end up getting loaded,         -- and things go wrong. We therefore link the libraries         -- with the same RTS flags that we link GHC with.-        dflags1 = if cGhcThreaded then addWay' WayThreaded dflags0-                                  else                     dflags0-        dflags2 = if cGhcDebugged then addWay' WayDebug dflags1-                                  else                  dflags1+        dflags1 = if platformMisc_ghcThreaded $ platformMisc dflags0+          then addWay' WayThreaded dflags0+          else                     dflags0+        dflags2 = if platformMisc_ghcDebugged $ platformMisc dflags1+          then addWay' WayDebug dflags1+          else                  dflags1         dflags = updateWays dflags2          verbFlags = getVerbFlags dflags@@ -630,5 +469,5 @@ Unregisterised compiler can't evade R_*_COPY relocations easily thus we disable -Bsymbolic linking there. -See related Trac tickets: #4210, #15338+See related tickets: #4210, #15338 -}
compiler/main/SysTools/ExtraObj.hs view
@@ -17,7 +17,7 @@ import ErrUtils import DynFlags import Packages-import Platform+import GHC.Platform import Outputable import SrcLoc           ( noSrcSpan ) import Module@@ -40,7 +40,7 @@       oFile <- newTempName dflags TFL_GhcSession "o"       writeFile cFile xs       ccInfo <- liftIO $ getCompilerInfo dflags-      runCc dflags+      runCc Nothing dflags             ([Option        "-c",               FileOption "" cFile,               Option        "-o",@@ -93,7 +93,7 @@                   _                      -> exeMain      exeMain = vcat [-        text "#include \"Rts.h\"",+        text "#include <Rts.h>",         text "extern StgClosure ZCMain_main_closure;",         text "int main(int argc, char *argv[])",         char '{',@@ -119,7 +119,7 @@         ]      dllMain = vcat [-        text "#include \"Rts.h\"",+        text "#include <Rts.h>",         text "#include <windows.h>",         text "#include <stdbool.h>",         char '\n',
compiler/main/SysTools/Info.hs view
@@ -19,14 +19,14 @@  import System.IO -import Platform+import GHC.Platform import GhcPrelude  import SysTools.Process  {- Note [Run-time linker info] -See also: Trac #5240, Trac #6063, Trac #10110+See also: #5240, #6063, #10110  Before 'runLink', we need to be sure to get the relevant information about the linker we're using at runtime to see if we need any extra@@ -127,8 +127,8 @@       parseLinkerInfo stdo _stde _exitc         | any ("GNU ld" `isPrefixOf`) stdo =           -- GNU ld specifically needs to use less memory. This especially-          -- hurts on small object files. Trac #5240.-          -- Set DT_NEEDED for all shared libraries. Trac #10110.+          -- hurts on small object files. #5240.+          -- Set DT_NEEDED for all shared libraries. #10110.           -- TODO: Investigate if these help or hurt when using split sections.           return (GnuLD $ map Option ["-Wl,--hash-size=31",                                       "-Wl,--reduce-memory-overheads",@@ -137,7 +137,7 @@                                       "-Wl,--no-as-needed"])          | any ("GNU gold" `isPrefixOf`) stdo =-          -- GNU gold only needs --no-as-needed. Trac #10110.+          -- GNU gold only needs --no-as-needed. #10110.           -- ELF specific flag, see Note [ELF needed shared libs]           return (GnuGold [Option "-Wl,--no-as-needed"]) @@ -219,7 +219,7 @@ -- See Note [Run-time linker info]. getCompilerInfo' :: DynFlags -> IO CompilerInfo getCompilerInfo' dflags = do-  let (pgm,_) = pgm_c dflags+  let pgm = pgm_c dflags       -- Try to grab the info from the process output.       parseCompilerInfo _stdo stde _exitc         -- Regular GCC@@ -231,13 +231,13 @@         -- FreeBSD clang         | any ("FreeBSD clang version" `isInfixOf`) stde =           return Clang-        -- XCode 5.1 clang+        -- Xcode 5.1 clang         | any ("Apple LLVM version 5.1" `isPrefixOf`) stde =           return AppleClang51-        -- XCode 5 clang+        -- Xcode 5 clang         | any ("Apple LLVM version" `isPrefixOf`) stde =           return AppleClang-        -- XCode 4.1 clang+        -- Xcode 4.1 clang         | any ("Apple clang version" `isPrefixOf`) stde =           return AppleClang          -- Unknown linker.
compiler/main/SysTools/Process.hs view
@@ -8,7 +8,7 @@ ----------------------------------------------------------------------------- module SysTools.Process where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import Exception import ErrUtils@@ -32,19 +32,6 @@  import FileCleanup --- | Enable process jobs support on Windows if it can be expected to work (e.g.--- @process >= 1.6.8.0@).-enableProcessJobs :: CreateProcess -> CreateProcess-#if defined(MIN_VERSION_process)-#if MIN_VERSION_process(1,6,8)-enableProcessJobs opts = opts { use_process_jobs = True }-#else-enableProcessJobs opts = opts-#endif-#else-enableProcessJobs opts = opts-#endif- -- Similar to System.Process.readCreateProcessWithExitCode, but stderr is -- inherited from the parent process, and output to stderr is not captured. readCreateProcessWithExitCode'@@ -81,7 +68,7 @@     -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr) readProcessEnvWithExitCode prog args env_update = do     current_env <- getEnvironment-    readCreateProcessWithExitCode (enableProcessJobs $ proc prog args) {+    readCreateProcessWithExitCode (proc prog args) {         env = Just (replaceVar env_update current_env) } ""  -- Don't let gcc localize version info string, #8825@@ -136,7 +123,7 @@ -- response files for passing them in. See: -- --     https://gcc.gnu.org/wiki/Response_Files---     https://ghc.haskell.org/trac/ghc/ticket/10777+--     https://gitlab.haskell.org/ghc/ghc/issues/10777 runSomethingResponseFile   :: DynFlags -> (String->String) -> String -> String -> [Option]   -> Maybe [(String,String)] -> IO ()@@ -233,22 +220,8 @@   -- unless an exception was raised.   let safely inner = mask $ \restore -> do         -- acquire-        -- 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 =-              enableProcessJobs-              $ (proc pgm real_args) { cwd = mb_cwd-                                     , env = mb_env-                                     , std_in  = CreatePipe-                                     , std_out = CreatePipe-                                     , std_err = CreatePipe-                                     }-        (Just hStdIn, Just hStdOut, Just hStdErr, hProcess) <- restore $-          createProcess_ "builderMainLoop" procdata+        (hStdIn, hStdOut, hStdErr, hProcess) <- restore $+          runInteractiveProcess pgm real_args mb_cwd mb_env         let cleanup_handles = do               hClose hStdIn               hClose hStdOut
+ compiler/main/SysTools/Settings.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}++module SysTools.Settings+ ( SettingsError (..)+ , initSettings+ ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Settings++import Config+import CliOption+import FileSettings+import Fingerprint+import GHC.Platform+import GhcNameVersion+import Outputable+import Settings+import SysTools.BaseDir+import ToolSettings++import Control.Monad.Trans.Except+import Control.Monad.IO.Class+import qualified Data.Map as Map+import System.FilePath+import System.Directory++data SettingsError+  = SettingsError_MissingData String+  | SettingsError_BadData String++initSettings+  :: forall m+  .  MonadIO m+  => String -- ^ TopDir path+  -> ExceptT SettingsError m Settings+initSettings top_dir = do+  -- see Note [topdir: How GHC finds its files]+  -- NB: top_dir is assumed to be in standard Unix+  -- format, '/' separated+  mtool_dir <- liftIO $ findToolDir top_dir+        -- see Note [tooldir: How GHC finds mingw on Windows]++  let installed :: FilePath -> FilePath+      installed file = top_dir </> file+      libexec :: FilePath -> FilePath+      libexec file = top_dir </> "bin" </> file+      settingsFile = installed "settings"+      platformConstantsFile = installed "platformConstants"++      readFileSafe :: FilePath -> ExceptT SettingsError m String+      readFileSafe path = liftIO (doesFileExist path) >>= \case+        True -> liftIO $ readFile path+        False -> throwE $ SettingsError_MissingData $ "Missing file: " ++ path++  settingsStr <- readFileSafe settingsFile+  platformConstantsStr <- readFileSafe platformConstantsFile+  settingsList <- case maybeReadFuzzy settingsStr of+    Just s -> pure s+    Nothing -> throwE $ SettingsError_BadData $+      "Can't parse " ++ show settingsFile+  let mySettings = Map.fromList settingsList+  platformConstants <- case maybeReadFuzzy platformConstantsStr of+    Just s -> pure s+    Nothing -> throwE $ SettingsError_BadData $+      "Can't parse " ++ show platformConstantsFile+  -- See Note [Settings file] for a little more about this file. We're+  -- just partially applying those functions and throwing 'Left's; they're+  -- written in a very portable style to keep ghc-boot light.+  let getSetting key = either pgmError pure $+        getFilePathSetting0 top_dir settingsFile mySettings key+      getToolSetting :: String -> ExceptT SettingsError m String+      getToolSetting key = expandToolDir mtool_dir <$> getSetting key+      getBooleanSetting :: String -> ExceptT SettingsError m Bool+      getBooleanSetting key = either pgmError pure $+        getBooleanSetting0 settingsFile mySettings key+  targetPlatformString <- getSetting "target platform string"+  tablesNextToCode <- getBooleanSetting "Tables next to code"+  myExtraGccViaCFlags <- getSetting "GCC extra via C opts"+  -- On Windows, mingw is distributed with GHC,+  -- so we look in TopDir/../mingw/bin,+  -- as well as TopDir/../../mingw/bin for hadrian.+  -- It would perhaps be nice to be able to override this+  -- with the settings file, but it would be a little fiddly+  -- to make that possible, so for now you can't.+  cc_prog <- getToolSetting "C compiler command"+  cc_args_str <- getSetting "C compiler flags"+  cxx_args_str <- getSetting "C++ compiler flags"+  gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie"+  cpp_prog <- getToolSetting "Haskell CPP command"+  cpp_args_str <- getSetting "Haskell CPP flags"++  platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings++  let unreg_cc_args = if platformUnregisterised platform+                      then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]+                      else []+      cpp_args = map Option (words cpp_args_str)+      cc_args  = words cc_args_str ++ unreg_cc_args+      cxx_args = words cxx_args_str+  ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"+  ldSupportsBuildId       <- getBooleanSetting "ld supports build-id"+  ldSupportsFilelist      <- getBooleanSetting "ld supports filelist"+  ldIsGnuLd               <- getBooleanSetting "ld is GNU ld"++  let pkgconfig_path = installed "package.conf.d"+      ghc_usage_msg_path  = installed "ghc-usage.txt"+      ghci_usage_msg_path = installed "ghci-usage.txt"++  -- For all systems, unlit, split, mangle are GHC utilities+  -- architecture-specific stuff is done when building Config.hs+  unlit_path <- getToolSetting "unlit command"++  windres_path <- getToolSetting "windres command"+  libtool_path <- getToolSetting "libtool command"+  ar_path <- getToolSetting "ar command"+  ranlib_path <- getToolSetting "ranlib command"++  -- TODO this side-effect doesn't belong here. Reading and parsing the settings+  -- should be idempotent and accumulate no resources.+  tmpdir <- liftIO $ getTemporaryDirectory++  touch_path <- getToolSetting "touch command"++  mkdll_prog <- getToolSetting "dllwrap command"+  let mkdll_args = []++  -- cpp is derived from gcc on all platforms+  -- HACK, see setPgmP below. We keep 'words' here to remember to fix+  -- Config.hs one day.+++  -- Other things being equal, as and ld are simply gcc+  cc_link_args_str <- getSetting "C compiler link flags"+  let   as_prog  = cc_prog+        as_args  = map Option cc_args+        ld_prog  = cc_prog+        ld_args  = map Option (cc_args ++ words cc_link_args_str)++  llvmTarget <- getSetting "LLVM target"++  -- We just assume on command line+  lc_prog <- getSetting "LLVM llc command"+  lo_prog <- getSetting "LLVM opt command"+  lcc_prog <- getSetting "LLVM clang command"++  let iserv_prog = libexec "ghc-iserv"++  integerLibrary <- getSetting "integer library"+  integerLibraryType <- case integerLibrary of+    "integer-gmp" -> pure IntegerGMP+    "integer-simple" -> pure IntegerSimple+    _ -> pgmError $ unwords+      [ "Entry for"+      , show "integer library"+      , "must be one of"+      , show "integer-gmp"+      , "or"+      , show "integer-simple"+      ]++  ghcWithInterpreter <- getBooleanSetting "Use interpreter"+  ghcWithNativeCodeGen <- getBooleanSetting "Use native code generator"+  ghcWithSMP <- getBooleanSetting "Support SMP"+  ghcRTSWays <- getSetting "RTS ways"+  leadingUnderscore <- getBooleanSetting "Leading underscore"+  useLibFFI <- getBooleanSetting "Use LibFFI"+  ghcThreaded <- getBooleanSetting "Use Threads"+  ghcDebugged <- getBooleanSetting "Use Debugging"+  ghcRtsWithLibdw <- getBooleanSetting "RTS expects libdw"++  return $ Settings+    { sGhcNameVersion = GhcNameVersion+      { ghcNameVersion_programName = "ghc"+      , ghcNameVersion_projectVersion = cProjectVersion+      }++    , sFileSettings = FileSettings+      { fileSettings_tmpDir         = normalise tmpdir+      , fileSettings_ghcUsagePath   = ghc_usage_msg_path+      , fileSettings_ghciUsagePath  = ghci_usage_msg_path+      , fileSettings_toolDir        = mtool_dir+      , fileSettings_topDir         = top_dir+      , fileSettings_systemPackageConfig = pkgconfig_path+      }++    , sToolSettings = ToolSettings+      { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind+      , toolSettings_ldSupportsBuildId       = ldSupportsBuildId+      , toolSettings_ldSupportsFilelist      = ldSupportsFilelist+      , toolSettings_ldIsGnuLd               = ldIsGnuLd+      , toolSettings_ccSupportsNoPie         = gccSupportsNoPie++      , toolSettings_pgm_L   = unlit_path+      , toolSettings_pgm_P   = (cpp_prog, cpp_args)+      , toolSettings_pgm_F   = ""+      , toolSettings_pgm_c   = cc_prog+      , toolSettings_pgm_a   = (as_prog, as_args)+      , toolSettings_pgm_l   = (ld_prog, ld_args)+      , toolSettings_pgm_dll = (mkdll_prog,mkdll_args)+      , toolSettings_pgm_T   = touch_path+      , toolSettings_pgm_windres = windres_path+      , toolSettings_pgm_libtool = libtool_path+      , toolSettings_pgm_ar = ar_path+      , toolSettings_pgm_ranlib = ranlib_path+      , toolSettings_pgm_lo  = (lo_prog,[])+      , toolSettings_pgm_lc  = (lc_prog,[])+      , toolSettings_pgm_lcc = (lcc_prog,[])+      , toolSettings_pgm_i   = iserv_prog+      , toolSettings_opt_L       = []+      , toolSettings_opt_P       = []+      , toolSettings_opt_P_fingerprint = fingerprint0+      , toolSettings_opt_F       = []+      , toolSettings_opt_c       = cc_args+      , toolSettings_opt_cxx     = cxx_args+      , toolSettings_opt_a       = []+      , toolSettings_opt_l       = []+      , toolSettings_opt_windres = []+      , toolSettings_opt_lcc     = []+      , toolSettings_opt_lo      = []+      , toolSettings_opt_lc      = []+      , toolSettings_opt_i       = []++      , toolSettings_extraGccViaCFlags = words myExtraGccViaCFlags+      }++    , sTargetPlatform = platform+    , sPlatformMisc = PlatformMisc+      { platformMisc_targetPlatformString = targetPlatformString+      , platformMisc_integerLibrary = integerLibrary+      , platformMisc_integerLibraryType = integerLibraryType+      , platformMisc_ghcWithInterpreter = ghcWithInterpreter+      , platformMisc_ghcWithNativeCodeGen = ghcWithNativeCodeGen+      , platformMisc_ghcWithSMP = ghcWithSMP+      , platformMisc_ghcRTSWays = ghcRTSWays+      , platformMisc_tablesNextToCode = tablesNextToCode+      , platformMisc_leadingUnderscore = leadingUnderscore+      , platformMisc_libFFI = useLibFFI+      , platformMisc_ghcThreaded = ghcThreaded+      , platformMisc_ghcDebugged = ghcDebugged+      , platformMisc_ghcRtsWithLibdw = ghcRtsWithLibdw+      , platformMisc_llvmTarget = llvmTarget+      }++    , sPlatformConstants = platformConstants++    , sRawSettings    = settingsList+    }
compiler/main/SysTools/Tasks.hs view
@@ -10,9 +10,10 @@  import Exception import ErrUtils+import HscTypes import DynFlags import Outputable-import Platform+import GHC.Platform import Util  import Data.List@@ -35,14 +36,14 @@ -}  runUnlit :: DynFlags -> [Option] -> IO ()-runUnlit dflags args = do+runUnlit dflags args = traceToolCommand dflags "unlit" $ do   let prog = pgm_L dflags       opts = getOpts dflags opt_L   runSomething dflags "Literate pre-processor" prog                (map Option opts ++ args)  runCpp :: DynFlags -> [Option] -> IO ()-runCpp dflags args =   do+runCpp dflags args = traceToolCommand dflags "cpp" $ do   let (p,args0) = pgm_P dflags       args1 = map Option (getOpts dflags opt_P)       args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags]@@ -52,16 +53,17 @@                        (args0 ++ args1 ++ args2 ++ args) Nothing mb_env  runPp :: DynFlags -> [Option] -> IO ()-runPp dflags args =   do+runPp dflags args = traceToolCommand dflags "pp" $ do   let prog = pgm_F dflags       opts = map Option (getOpts dflags opt_F)   runSomething dflags "Haskell pre-processor" prog (args ++ opts) -runCc :: DynFlags -> [Option] -> IO ()-runCc dflags args =   do-  let (p,args0) = pgm_c dflags-      args1 = map Option (getOpts dflags opt_c)-      args2 = args0 ++ args ++ args1+-- | Run compiler of C-like languages and raw objects (such as gcc or clang).+runCc :: Maybe ForeignSrcLang -> DynFlags -> [Option] -> IO ()+runCc mLanguage dflags args = traceToolCommand dflags "cc" $ do+  let p = pgm_c dflags+      args1 = map Option userOpts+      args2 = languageOptions ++ args ++ args1       -- We take care to pass -optc flags in args1 last to ensure that the       -- user can override flags passed by GHC. See #14452.   mb_env <- getGccEnv args2@@ -117,12 +119,30 @@    | "warning: call-clobbered register used" `isContainedIn` w = False    | otherwise = True +  -- force the C compiler to interpret this file as C when+  -- compiling .hc files, by adding the -x c option.+  -- Also useful for plain .c files, just in case GHC saw a+  -- -x c option.+  (languageOptions, userOpts) = case mLanguage of+    Nothing -> ([], userOpts_c)+    Just language -> ([Option "-x", Option languageName], opts)+      where+        (languageName, opts) = case language of+          LangC      -> ("c",             userOpts_c)+          LangCxx    -> ("c++",           userOpts_cxx)+          LangObjc   -> ("objective-c",   userOpts_c)+          LangObjcxx -> ("objective-c++", userOpts_cxx)+          LangAsm    -> ("assembler",     [])+          RawObject  -> ("c",             []) -- claim C for lack of a better idea+  userOpts_c   = getOpts dflags opt_c+  userOpts_cxx = getOpts dflags opt_cxx+ isContainedIn :: String -> String -> Bool xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)  -- | Run the linker with some arguments and return the output askLd :: DynFlags -> [Option] -> IO String-askLd dflags args = do+askLd dflags args = traceToolCommand dflags "linker" $ do   let (p,args0) = pgm_l dflags       args1     = map Option (getOpts dflags opt_l)       args2     = args0 ++ args1 ++ args@@ -130,13 +150,8 @@   runSomethingWith dflags "gcc" p args2 $ \real_args ->     readCreateProcessWithExitCode' (proc p real_args){ env = mb_env } -runSplit :: DynFlags -> [Option] -> IO ()-runSplit dflags args = do-  let (p,args0) = pgm_s dflags-  runSomething dflags "Splitter" p (args0++args)- runAs :: DynFlags -> [Option] -> IO ()-runAs dflags args = do+runAs dflags args = traceToolCommand dflags "as" $ do   let (p,args0) = pgm_a dflags       args1 = map Option (getOpts dflags opt_a)       args2 = args0 ++ args1 ++ args@@ -145,7 +160,7 @@  -- | Run the LLVM Optimiser runLlvmOpt :: DynFlags -> [Option] -> IO ()-runLlvmOpt dflags args = do+runLlvmOpt dflags args = traceToolCommand dflags "opt" $ do   let (p,args0) = pgm_lo dflags       args1 = map Option (getOpts dflags opt_lo)       -- We take care to pass -optlo flags (e.g. args0) last to ensure that the@@ -154,7 +169,7 @@  -- | Run the LLVM Compiler runLlvmLlc :: DynFlags -> [Option] -> IO ()-runLlvmLlc dflags args = do+runLlvmLlc dflags args = traceToolCommand dflags "llc" $ do   let (p,args0) = pgm_lc dflags       args1 = map Option (getOpts dflags opt_lc)   runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args)@@ -163,7 +178,7 @@ -- backend on OS X as LLVM doesn't support the OS X system -- assembler) runClang :: DynFlags -> [Option] -> IO ()-runClang dflags args = do+runClang dflags args = traceToolCommand dflags "clang" $ do   let (clang,_) = pgm_lcc dflags       -- be careful what options we call clang with       -- see #5903 and #7617 for bugs caused by this.@@ -184,7 +199,7 @@  -- | Figure out which version of LLVM we are running this session figureLlvmVersion :: DynFlags -> IO (Maybe LlvmVersion)-figureLlvmVersion dflags = do+figureLlvmVersion dflags = traceToolCommand dflags "llc" $ do   let (pgm,opts) = pgm_lc dflags       args = filter notNull (map showOpt opts)       -- we grab the args even though they should be useless just in@@ -222,12 +237,16 @@   runLink :: DynFlags -> [Option] -> IO ()-runLink dflags args = do+runLink dflags args = traceToolCommand dflags "linker" $ do   -- See Note [Run-time linker info]+  --+  -- `-optl` args come at the end, so that later `-l` options+  -- given there manually can fill in symbols needed by+  -- Haskell libaries coming in via `args`.   linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags   let (p,args0) = pgm_l dflags-      args1     = map Option (getOpts dflags opt_l)-      args2     = args0 ++ linkargs ++ args1 ++ args+      optl_args = map Option (getOpts dflags opt_l)+      args2     = args0 ++ linkargs ++ args ++ optl_args   mb_env <- getGccEnv args2   runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env   where@@ -282,7 +301,7 @@   runLibtool :: DynFlags -> [Option] -> IO ()-runLibtool dflags args = do+runLibtool dflags args = traceToolCommand dflags "libtool" $ do   linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags   let args1      = map Option (getOpts dflags opt_l)       args2      = [Option "-static"] ++ args1 ++ args ++ linkargs@@ -291,31 +310,32 @@   runSomethingFiltered dflags id "Linker" libtool args2 Nothing mb_env  runAr :: DynFlags -> Maybe FilePath -> [Option] -> IO ()-runAr dflags cwd args = do+runAr dflags cwd args = traceToolCommand dflags "ar" $ do   let ar = pgm_ar dflags   runSomethingFiltered dflags id "Ar" ar args cwd Nothing  askAr :: DynFlags -> Maybe FilePath -> [Option] -> IO String-askAr dflags mb_cwd args = do+askAr dflags mb_cwd args = traceToolCommand dflags "ar" $ do   let ar = pgm_ar dflags   runSomethingWith dflags "Ar" ar args $ \real_args ->     readCreateProcessWithExitCode' (proc ar real_args){ cwd = mb_cwd }  runRanlib :: DynFlags -> [Option] -> IO ()-runRanlib dflags args = do+runRanlib dflags args = traceToolCommand dflags "ranlib" $ do   let ranlib = pgm_ranlib dflags   runSomethingFiltered dflags id "Ranlib" ranlib args Nothing Nothing  runMkDLL :: DynFlags -> [Option] -> IO ()-runMkDLL dflags args = do+runMkDLL dflags args = traceToolCommand dflags "mkdll" $ do   let (p,args0) = pgm_dll dflags       args1 = args0 ++ args   mb_env <- getGccEnv (args0++args)   runSomethingFiltered dflags id "Make DLL" p args1 Nothing mb_env  runWindres :: DynFlags -> [Option] -> IO ()-runWindres dflags args = do-  let (gcc, gcc_args) = pgm_c dflags+runWindres dflags args = traceToolCommand dflags "windres" $ do+  let cc = pgm_c dflags+      cc_args = map Option (sOpt_c (settings dflags))       windres = pgm_windres dflags       opts = map Option (getOpts dflags opt_windres)       quote x = "\"" ++ x ++ "\""@@ -323,8 +343,7 @@               -- spaces then windres fails to run gcc. We therefore need               -- to tell it what command to use...               Option ("--preprocessor=" ++-                      unwords (map quote (gcc :-                                          map showOpt gcc_args +++                      unwords (map quote (cc :                                           map showOpt opts ++                                           ["-E", "-xc", "-DRC_INVOKED"])))               -- ...but if we do that then if windres calls popen then@@ -333,9 +352,22 @@               -- See #1828.             : Option "--use-temp-file"             : args-  mb_env <- getGccEnv gcc_args+  mb_env <- getGccEnv cc_args   runSomethingFiltered dflags id "Windres" windres args' Nothing mb_env  touch :: DynFlags -> String -> String -> IO ()-touch dflags purpose arg =+touch dflags purpose arg = traceToolCommand dflags "touch" $   runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]++-- * Tracing utility++-- | Record in the eventlog when the given tool command starts+--   and finishes, prepending the given 'String' with+--   \"systool:\", to easily be able to collect and process+--   all the systool events.+--+--   For those events to show up in the eventlog, you need+--   to run GHC with @-v2@ or @-ddump-timings@.+traceToolCommand :: DynFlags -> String -> IO a -> IO a+traceToolCommand dflags tool = withTiming+  dflags (text $ "systool:" ++ tool) (const ())
compiler/main/TidyPgm.hs view
@@ -4,13 +4,13 @@ \section{Tidying up Core} -} -{-# LANGUAGE CPP, ViewPatterns #-}+{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns #-}  module TidyPgm (        mkBootModDetailsTc, tidyProgram    ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -63,7 +63,7 @@  import Control.Monad import Data.Function-import Data.List        ( sortBy )+import Data.List        ( sortBy, mapAccumL ) import Data.IORef       ( atomicModifyIORef' )  {-@@ -145,7 +145,7 @@                 }   = -- This timing isn't terribly useful since the result isn't forced, but     -- the message is useful to locating oneself in the compilation process.-    Err.withTiming (pure dflags)+    Err.withTiming dflags                    (text "CoreTidy"<+>brackets (ppr this_mod))                    (const ()) $     return (ModDetails { md_types         = type_env'@@ -247,8 +247,8 @@ Note [Choosing external Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See also the section "Interface stability" in the-RecompilationAvoidance commentary:-  http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance+recompilation-avoidance commentary:+  https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance  First we figure out which Ids are "external" Ids.  An "external" Id is one that is visible from outside the compilation@@ -341,7 +341,7 @@                               , mg_modBreaks = modBreaks                               }) -  = Err.withTiming (pure dflags)+  = Err.withTiming dflags                    (text "CoreTidy"<+>brackets (ppr mod))                    (const ()) $     do  { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags@@ -466,7 +466,7 @@ Note [Don't attempt to trim data types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For some time GHC tried to avoid exporting the data constructors-of a data type if it wasn't strictly necessary to do so; see Trac #835.+of a data type if it wasn't strictly necessary to do so; see #835. But "strictly necessary" accumulated a longer and longer list of exceptions, and finally I gave up the battle: @@ -481,7 +481,7 @@     there are a lot of exceptions, notably when Template Haskell is     involved or, more recently, DataKinds. -    However Trac #7445 shows that even without TemplateHaskell, using+    However #7445 shows that even without TemplateHaskell, using     the Data class and invoking Language.Haskell.TH.Quote.dataToExpQ     is enough to require us to expose the data constructors. @@ -508,7 +508,7 @@ This generates bad code unless it's first simplified a bit.  That is why CoreUnfold.mkImplicitUnfolding uses simpleOptExpr to do a bit of optimisation first.  (Only matters when the selector is used curried;-eg map x ys.)  See Trac #2070.+eg map x ys.)  See #2070.  [Oct 09: in fact, record selectors are no longer implicit Ids at all, because we really do want to optimise them properly. They are treated@@ -521,7 +521,7 @@ simplifier and other core-to-core passes mess with IdInfo all the time.  The straw that broke the camels back was when a class selector got the wrong arity -- ie the simplifier gave it arity 2, whereas-importing modules were expecting it to have arity 1 (Trac #2844).+importing modules were expecting it to have arity 1 (#2844). It's much safer just to inject them right at the end, after tidying.  Oh: two other reasons for injecting them late:@@ -550,7 +550,9 @@     cls_binds = maybe [] getClassImplicitBinds (tyConClass_maybe tc)  getTyConImplicitBinds :: TyCon -> [CoreBind]-getTyConImplicitBinds tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))+getTyConImplicitBinds tc+  | isNewTyCon tc = []  -- See Note [Compulsory newtype unfolding] in MkId+  | otherwise     = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))  getClassImplicitBinds :: Class -> [CoreBind] getClassImplicitBinds cls@@ -735,9 +737,7 @@                               -- we don't want to record these as free vars       -> (VarSet, [Var])      -- Input State: (set, list) of free vars so far       -> ((VarSet,[Var]),a))  -- Output state--instance Functor DFFV where-    fmap = liftM+    deriving (Functor)  instance Applicative DFFV where     pure a = DFFV $ \_ st -> (st, a)@@ -1089,12 +1089,7 @@      init_env = (init_occ_env, emptyVarEnv) -    tidy _           env []     = (env, [])-    tidy cvt_literal env (b:bs)-        = let (env1, b')  = tidyTopBind dflags this_mod cvt_literal unfold_env-                                        env b-              (env2, bs') = tidy cvt_literal env1 bs-          in  (env2, b':bs')+    tidy cvt_literal = mapAccumL (tidyTopBind dflags this_mod cvt_literal unfold_env)  ------------------------ tidyTopBind  :: DynFlags@@ -1236,7 +1231,7 @@     --     marked NOINLINE or something like that     -- This is important: if you expose the worker for a loop-breaker     -- then you can make the simplifier go into an infinite loop, because-    -- in effect the unfolding is exposed.  See Trac #1709+    -- in effect the unfolding is exposed.  See #1709     --     -- You might think that if show_unfold is False, then the thing should     -- not be w/w'd in the first place.  But a legitimate reason is this:@@ -1397,7 +1392,7 @@ -O.  But that is not always possible: see the old Note [When we can't trim types] below for exceptions. -Then (Trac #7445) I realised that the TH problem arises for any data type+Then (#7445) I realised that the TH problem arises for any data type that we have deriving( Data ), because we can invoke    Language.Haskell.TH.Quote.dataToExpQ to get a TH Exp representation of a value built from that data type.@@ -1422,7 +1417,7 @@  But there are some times we can't do that, indicated by the 'no_trim_types' flag. -First, Template Haskell.  Consider (Trac #2386) this+First, Template Haskell.  Consider (#2386) this         module M(T, makeOne) where           data T = Yay String           makeOne = [| Yay "Yep" |]@@ -1431,7 +1426,7 @@ so it'd better be there.  Hence, brutally but simply, we switch off type constructor trimming if TH is enabled in this module. -Second, data kinds.  Consider (Trac #5912)+Second, data kinds.  Consider (#5912)      {-# LANGUAGE DataKinds #-}      module M() where      data UnaryTypeC a = UnaryDataC a
compiler/nativeGen/AsmCodeGen.hs view
@@ -6,7 +6,8 @@ -- -- ----------------------------------------------------------------------------- -{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, PatternSynonyms #-}+{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, PatternSynonyms,+    DeriveFunctor #-}  #if !defined(GHC_LOADED_INTO_GHCI) {-# LANGUAGE UnboxedTuples #-}@@ -25,9 +26,7 @@                   , x86NcgImpl                   ) where -#include "GhclibHsVersions.h"-#include "nativeGen/NCG.h"-+#include "HsVersions.h"  import GhcPrelude @@ -59,7 +58,7 @@  import AsmUtils import TargetReg-import Platform+import GHC.Platform import BlockLayout import Config import Instruction@@ -71,7 +70,7 @@ import Debug  import BlockId-import CgUtils          ( fixStgRegisters )+import GHC.StgToCmm.CgUtils ( fixStgRegisters ) import Cmm import CmmUtils import Hoopl.Collections@@ -156,19 +155,20 @@ -}  ---------------------nativeCodeGen :: DynFlags -> Module -> ModLocation -> Handle -> UniqSupply-              -> Stream IO RawCmmGroup ()-              -> IO UniqSupply+nativeCodeGen :: forall a . DynFlags -> Module -> ModLocation -> Handle -> UniqSupply+              -> Stream IO RawCmmGroup a+              -> IO a nativeCodeGen dflags this_mod modLoc h us cmms  = let platform = targetPlatform dflags        nCG' :: ( Outputable statics, Outputable instr                , Outputable jumpDest, Instruction instr)-            => NcgImpl statics instr jumpDest -> IO UniqSupply+            => NcgImpl statics instr jumpDest -> IO a        nCG' ncgImpl = nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms    in case platformArch platform of       ArchX86       -> nCG' (x86NcgImpl    dflags)       ArchX86_64    -> nCG' (x86_64NcgImpl dflags)       ArchPPC       -> nCG' (ppcNcgImpl    dflags)+      ArchS390X     -> panic "nativeCodeGen: No NCG for S390X"       ArchSPARC     -> nCG' (sparcNcgImpl  dflags)       ArchSPARC64   -> panic "nativeCodeGen: No NCG for SPARC64"       ArchARM {}    -> panic "nativeCodeGen: No NCG for ARM"@@ -183,7 +183,7 @@ x86NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics)                                   X86.Instr.Instr X86.Instr.JumpDest x86NcgImpl dflags- = (x86_64NcgImpl dflags) { ncg_x86fp_kludge = map x86fp_kludge }+ = (x86_64NcgImpl dflags)  x86_64NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics)                                   X86.Instr.Instr X86.Instr.JumpDest@@ -198,7 +198,6 @@        ,pprNatCmmDecl             = X86.Ppr.pprNatCmmDecl        ,maxSpillSlots             = X86.Instr.maxSpillSlots dflags        ,allocatableRegs           = X86.Regs.allocatableRegs platform-       ,ncg_x86fp_kludge          = id        ,ncgAllocMoreStack         = X86.Instr.allocMoreStack platform        ,ncgExpandTop              = id        ,ncgMakeFarBranches        = const id@@ -219,7 +218,6 @@        ,pprNatCmmDecl             = PPC.Ppr.pprNatCmmDecl        ,maxSpillSlots             = PPC.Instr.maxSpillSlots dflags        ,allocatableRegs           = PPC.Regs.allocatableRegs platform-       ,ncg_x86fp_kludge          = id        ,ncgAllocMoreStack         = PPC.Instr.allocMoreStack platform        ,ncgExpandTop              = id        ,ncgMakeFarBranches        = PPC.Instr.makeFarBranches@@ -240,7 +238,6 @@        ,pprNatCmmDecl             = SPARC.Ppr.pprNatCmmDecl        ,maxSpillSlots             = SPARC.Instr.maxSpillSlots dflags        ,allocatableRegs           = SPARC.Regs.allocatableRegs-       ,ncg_x86fp_kludge          = id        ,ncgAllocMoreStack         = noAllocMoreStack        ,ncgExpandTop              = map SPARC.CodeGen.Expand.expandTop        ,ncgMakeFarBranches        = const id@@ -316,8 +313,8 @@                -> NcgImpl statics instr jumpDest                -> Handle                -> UniqSupply-               -> Stream IO RawCmmGroup ()-               -> IO UniqSupply+               -> Stream IO RawCmmGroup a+               -> IO a nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms  = do         -- BufHandle is a performance hack.  We could hide it inside@@ -325,9 +322,10 @@         -- printDocs here (in order to do codegen in constant space).         bufh <- newBufHandle h         let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty-        (ngs, us') <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us+        (ngs, us', a) <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us                                          cmms ngs0-        finishNativeGen dflags modLoc bufh us' ngs+        _ <- finishNativeGen dflags modLoc bufh us' ngs+        return a  finishNativeGen :: Instruction instr                 => DynFlags@@ -337,9 +335,9 @@                 -> NativeGenAcc statics instr                 -> IO UniqSupply finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs- = do+ = withTimingSilent dflags (text "NCG") (`seq` ()) $ do         -- Write debug data and finish-        let emitDw = debugLevel dflags > 0 && not (gopt Opt_SplitObjs dflags)+        let emitDw = debugLevel dflags > 0         us' <- if not emitDw then return us else do           (dwarf, us') <- dwarfGen dflags modLoc us (ngs_debug ngs)           emitNativeCode dflags bufh dwarf@@ -348,7 +346,7 @@          -- dump global NCG stats for graph coloring allocator         let stats = concat (ngs_colorStats ngs)-        when (not (null stats)) $ do+        unless (null stats) $ do            -- build the global register conflict graph           let graphGlobal@@ -371,7 +369,7 @@          -- dump global NCG stats for linear allocator         let linearStats = concat (ngs_linearStats ngs)-        when (not (null linearStats)) $+        unless (null linearStats) $           dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats)          -- write out the imports@@ -388,62 +386,52 @@               -> NcgImpl statics instr jumpDest               -> BufHandle               -> UniqSupply-              -> Stream IO RawCmmGroup ()+              -> Stream IO RawCmmGroup a               -> NativeGenAcc statics instr-              -> IO (NativeGenAcc statics instr, UniqSupply)+              -> IO (NativeGenAcc statics instr, UniqSupply, a)  cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs  = do r <- Stream.runStream cmm_stream       case r of-        Left () ->+        Left a ->           return (ngs { ngs_imports = reverse $ ngs_imports ngs                       , ngs_natives = reverse $ ngs_natives ngs                       , ngs_colorStats = reverse $ ngs_colorStats ngs                       , ngs_linearStats = reverse $ ngs_linearStats ngs                       },-                  us)+                  us,+                  a)         Right (cmms, cmm_stream') -> do--          -- Generate debug information-          let debugFlag = debugLevel dflags > 0-              !ndbgs | debugFlag = cmmDebugGen modLoc cmms-                     | otherwise = []-              dbgMap = debugToMap ndbgs+          (us', ngs'') <-+            withTimingSilent+                dflags+                ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do+              -- Generate debug information+              let debugFlag = debugLevel dflags > 0+                  !ndbgs | debugFlag = cmmDebugGen modLoc cmms+                         | otherwise = []+                  dbgMap = debugToMap ndbgs -          -- Insert split marker, generate native code-          let splitObjs = gopt Opt_SplitObjs dflags-              split_marker = CmmProc mapEmpty mkSplitMarkerLabel [] $-                             ofBlockList (panic "split_marker_entry") []-              cmms' | splitObjs  = split_marker : cmms-                    | otherwise  = cmms-          (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h-                                             dbgMap us cmms' ngs 0+              -- Generate native code+              (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h+                                               dbgMap us cmms ngs 0 -          -- Link native code information into debug blocks-          -- See Note [What is this unwinding business?] in Debug.-          let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs-          dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"-            (vcat $ map ppr ldbgs)+              -- Link native code information into debug blocks+              -- See Note [What is this unwinding business?] in Debug.+              let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs+              unless (null ldbgs) $+                dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"+                  (vcat $ map ppr ldbgs) -          -- Emit & clear DWARF information when generating split-          -- object files, as we need it to land in the same object file-          -- When using split sections, note that we do not split the debug-          -- info but emit all the info at once in finishNativeGen.-          (ngs'', us'') <--            if debugFlag && splitObjs-            then do (dwarf, us'') <- dwarfGen dflags modLoc us ldbgs-                    emitNativeCode dflags h dwarf-                    return (ngs' { ngs_debug = []-                                 , ngs_dwarfFiles = emptyUFM-                                 , ngs_labels = [] },-                            us'')-            else return (ngs' { ngs_debug  = ngs_debug ngs' ++ ldbgs-                              , ngs_labels = [] },-                         us')+              -- Accumulate debug information for emission in finishNativeGen.+              let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }+              return (us', ngs'') -          cmmNativeGenStream dflags this_mod modLoc ncgImpl h us''+          cmmNativeGenStream dflags this_mod modLoc ncgImpl h us'               cmm_stream' ngs'' +    where ncglabel = text "NCG"+ -- | Do native code generation on all these cmms. -- cmmNativeGens :: forall statics instr jumpDest.@@ -483,14 +471,14 @@                          nonDetEltsUFM $ fileIds' `minusUFM` fileIds             -- See Note [Unique Determinism and code generation]             pprDecl (f,n) = text "\t.file " <> ppr n <+>-                            doubleQuotes (ftext f)+                            pprFilePathString (unpackFS f)          emitNativeCode dflags h $ vcat $           map pprDecl newFileIds ++           map (pprNatCmmDecl ncgImpl) native          -- force evaluation all this stuff to avoid space leaks-        {-# SCC "seqString" #-} evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports)+        {-# SCC "seqString" #-} evaluate $ seqList (showSDoc dflags $ vcat $ map ppr imports) ()          let !labels' = if debugLevel dflags > 0                        then cmmDebugLabels isMetaInstr native else []@@ -508,10 +496,7 @@                       }         go us' cmms ngs' (count + 1) -    seqString []            = ()-    seqString (x:xs)        = x `seq` seqString xs - emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO () emitNativeCode dflags h sdoc = do @@ -578,7 +563,6 @@                                         (cmmTopCodeGen ncgImpl)                                         fileIds dbgMap opt_cmm cmmCfg -         dumpIfSet_dyn dflags                 Opt_D_dump_asm_native "Native code"                 (vcat $ map (pprNatCmmDecl ncgImpl) native)@@ -594,9 +578,7 @@         let (withLiveness, usLive) =                 {-# SCC "regLiveness" #-}                 initUs usGen-                        $ mapM (regLiveness platform)-                        -- TODO: Only use CFG for x86-                        $ map (natCmmTopToLive livenessCfg) native+                        $ mapM (cmmTopLiveness livenessCfg platform) native          dumpIfSet_dyn dflags                 Opt_D_dump_asm_liveness "Liveness annotations added"@@ -700,29 +682,20 @@             cfgRegAllocUpdates = (concatMap Linear.ra_fixupList raStats)          let cfgWithFixupBlks =-                pure addNodesBetween <*> livenessCfg <*> pure cfgRegAllocUpdates+                (\cfg -> addNodesBetween cfg cfgRegAllocUpdates) <$> livenessCfg          -- Insert stack update blocks-        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-        ---- is clear, and library functions can return odd results if it-        ---- isn't.-        -----        ---- NB. must happen before shortcutBranches, because that-        ---- generates JXX_GBLs which we can't fix up in x86fp_kludge.-        let kludged = {-# SCC "x86fp_kludge" #-} ncg_x86fp_kludge ncgImpl alloced+        let postRegCFG =+                pure (foldl' (\m (from,to) -> addImmediateSuccessor from to m ))+                     <*> cfgWithFixupBlks+                     <*> pure stack_updt_blks          ---- generate jump tables         let tabled      =                 {-# SCC "generateJumpTables" #-}-                generateJumpTables ncgImpl kludged+                generateJumpTables ncgImpl alloced -        dumpIfSet_dyn dflags+        when (not $ null nativeCfgWeights) $ dumpIfSet_dyn dflags                 Opt_D_dump_cfg_weights "CFG Update information"                 ( text "stack:" <+> ppr stack_updt_blks $$                   text "linearAlloc:" <+> ppr cfgRegAllocUpdates )@@ -732,8 +705,9 @@                 {-# SCC "shortcutBranches" #-}                 shortcutBranches dflags ncgImpl tabled postRegCFG -        let optimizedCFG =-                optimizeCFG (cfgWeightInfo dflags) cmm <$> postShortCFG+        let optimizedCFG :: Maybe CFG+            optimizedCFG =+                optimizeCFG (cfgWeightInfo dflags) cmm <$!> postShortCFG          maybeDumpCfg dflags optimizedCFG "CFG Weights - Final" proc_name @@ -745,8 +719,9 @@                 (gopt Opt_DoAsmLinting dflags || debugIsOn )) $ do                 let blocks = concatMap getBlks shorted                 let labels = setFromList $ fmap blockId blocks :: LabelSet-                return $! seq (pure sanityCheckCfg <*> optimizedCFG <*> pure labels <*>-                                        pure (text "cfg not in lockstep")) ()+                let cfg = fromJust optimizedCFG+                return $! seq (sanityCheckCfg cfg labels $+                                text "cfg not in lockstep") ()          ---- sequence blocks         let sequenced :: [NatCmmDecl statics instr]@@ -765,7 +740,7 @@               where                 invertConds :: LabelMap CmmStatics -> [NatBasicBlock instr]                             -> [NatBasicBlock instr]-                invertConds = (invertCondBranches ncgImpl) optimizedCFG+                invertConds = invertCondBranches ncgImpl optimizedCFG                 invert top@CmmData {} = top                 invert (CmmProc info lbl live (ListGraph blocks)) =                     CmmProc info lbl live (ListGraph $ invertConds info blocks)@@ -824,12 +799,6 @@         getBlockIds (CmmProc _ _ _ (ListGraph blocks)) =                 setFromList $ map blockId blocks --x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr-x86fp_kludge top@(CmmData _ _) = top-x86fp_kludge (CmmProc info lbl live (ListGraph code)) =-        CmmProc info lbl live (ListGraph $ X86.Instr.i386_insert_ffrees code)- -- | Compute unwinding tables for the blocks of a procedure computeUnwinding :: Instruction instr                  => DynFlags -> NcgImpl statics instr jumpDest@@ -907,7 +876,7 @@                 | otherwise                 = Outputable.empty -        doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel platform lbl) astyle)+        doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel dflags lbl) astyle)         astyle = mkCodeStyle AsmStyle  -- -----------------------------------------------------------------------------@@ -1089,13 +1058,11 @@ {-# COMPLETE OptMResult #-} #else -data OptMResult a = OptMResult !a ![CLabel]+data OptMResult a = OptMResult !a ![CLabel] deriving (Functor) #endif  newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> OptMResult a)--instance Functor CmmOptM where-    fmap = liftM+    deriving (Functor)  instance Applicative CmmOptM where     pure x = CmmOptM $ \_ _ imports -> OptMResult x imports
compiler/nativeGen/BlockLayout.hs view
@@ -2,16 +2,18 @@ -- Copyright (c) 2018 Andreas Klebinger -- -{-# LANGUAGE TypeFamilies, ScopedTypeVariables, CPP #-}--{-# OPTIONS_GHC -fprof-auto #-}---{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -ddump-cmm #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}  module BlockLayout     ( sequenceTop ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h" import GhcPrelude  import Instruction@@ -22,7 +24,6 @@ import Cmm import Hoopl.Collections import Hoopl.Label-import Hoopl.Block  import DynFlags (gopt, GeneralFlag(..), DynFlags, backendMaintainsCfg) import UniqFM@@ -37,23 +38,40 @@ --import Debug --import Debug.Trace import ListSetOps (removeDups)-import PprCmm ()  import OrdList import Data.List import Data.Foldable (toList)-import Hoopl.Graph  import qualified Data.Set as Set-import Control.Applicative+import Data.STRef+import Control.Monad.ST.Strict+import Control.Monad (foldM)  {-+  Note [CFG based code layout]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~++  The major steps in placing blocks are as follow:+  * Compute a CFG based on the Cmm AST, see getCfgProc.+    This CFG will have edge weights representing a guess+    on how important they are.+  * After we convert Cmm to Asm we run `optimizeCFG` which+    adds a few more "educated guesses" to the equation.+  * Then we run loop analysis on the CFG (`loopInfo`) which tells us+    about loop headers, loop nesting levels and the sort.+  * Based on the CFG and loop information refine the edge weights+    in the CFG and normalize them relative to the most often visited+    node. (See `mkGlobalWeights`)+  * Feed this CFG into the block layout code (`sequenceTop`) in this+    module. Which will then produce a code layout based on the input weights.+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~   ~~~ Note [Chain based CFG serialization]   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~    For additional information also look at-  https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/CodeLayout+  https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/code-layout    We have a CFG with edge weights based on which we try to place blocks next to   each other.@@ -62,8 +80,8 @@   but also how much a block would benefit from being placed sequentially after   it's predecessor.   For example blocks which are preceeded by an info table are more likely to end-  up in a different cache line than their predecessor. So there is less benefit-  in placing them sequentially.+  up in a different cache line than their predecessor and we can't eliminate the jump+  so there is less benefit to placing them sequentially.    For example consider this example: @@ -83,56 +101,83 @@   Eg for our example we might end up with two chains like:   [A->B->C->X],[D]. Blocks inside chains will always be placed sequentially.   However there is no particular order in which chains are placed since-  (hopefully) the blocks for which sequentially is important have already+  (hopefully) the blocks for which sequentiality is important have already   been placed in the same chain.    ------------------------------------------------------------------------------      First try to create a lists of good chains.+     1) First try to create a list of good chains.   ----------------------------------------------------------------------------- -  We do so by taking a block not yet placed in a chain and-  looking at these cases:+  Good chains are these which allow us to eliminate jump instructions.+  Which further eliminate often executed jumps first. -  *)  Check if the best predecessor of the block is at the end of a chain.-      If so add the current block to the end of that chain.+  We do so by: -      Eg if we look at block C and already have the chain (A -> B)-      then we extend the chain to (A -> B -> C).+  *)  Ignore edges which represent instructions which can not be replaced+      by fall through control flow. Primarily calls and edges to blocks which+      are prefixed by a info table we have to jump across. -      Combined with the fact that we process blocks in reverse post order-      this means loop bodies and trivially sequential control flow already-      ends up as a single chain.+  *)  Then process remaining edges in order of frequency taken and: -  *)  Otherwise we create a singleton chain from the block we are looking at.-      Eg if we have from the example above already constructed (A->B)-      and look at D we create the chain (D) resulting in the chains [A->B, D]+    +)  If source and target have not been placed build a new chain from them. +    +)  If source and target have been placed, and are ends of differing chains+        try to merge the two chains.++    +)  If one side of the edge is a end/front of a chain, add the other block of+        to edge to the same chain++        Eg if we look at edge (B -> C) and already have the chain (A -> B)+        then we extend the chain to (A -> B -> C).++    +)  If the edge was used to modify or build a new chain remove the edge from+        our working list.++  *) If there any blocks not being placed into a chain after these steps we place+     them into a chain consisting of only this block.++  Ranking edges by their taken frequency, if+  two edges compete for fall through on the same target block, the one taken+  more often will automatically win out. Resulting in fewer instructions being+  executed.++  Creating singleton chains is required for situations where we have code of the+  form:++    A: goto B:+    <infoTable>+    B: goto C:+    <infoTable>+    C: ...++  As the code in block B is only connected to the rest of the program via edges+  which will be ignored in this step we make sure that B still ends up in a chain+  this way.+   ------------------------------------------------------------------------------      We then try to fuse chains.+     2) We also try to fuse chains.   ----------------------------------------------------------------------------- -  There are edge cases which result in two chains being created which trivially-  represent linear control flow. For example we might have the chains-  [(A-B-C),(D-E)] with an cfg triangle:+  As a result from the above step we still end up with multiple chains which+  represent sequential control flow chunks. But they are not yet suitable for+  code layout as we need to place *all* blocks into a single sequence. -      A----->C->D->E-       \->B-/+  In this step we combine chains result from the above step via these steps: -  We also get three independent chains if two branches end with a jump-  to a common successor.+  *)  Look at the ranked list of *all* edges, including calls/jumps across info tables+      and the like. -  We take care of these cases by fusing chains which are connected by an-  edge.+  *)  Look at each edge and -  We do so by looking at the list of edges sorted by weight.-  Given the edge (C -> D) we try to find two chains such that:-      * C is at the end of chain one.-      * D is in front of chain two.-      * If two such chains exist we fuse them.-  We then remove the edge and repeat the process for the rest of the edges.+    +) Given an edge (A -> B) try to find two chains for which+      * Block A is at the end of one chain+      * Block B is at the front of the other chain.+    +) If we find such a chain we "fuse" them into a single chain, remove the+       edge from working set and continue.+    +) If we can't find such chains we skip the edge and continue.    ------------------------------------------------------------------------------      Place indirect successors (neighbours) after each other+     3) Place indirect successors (neighbours) after each other   -----------------------------------------------------------------------------    We might have chains [A,B,C,X],[E] in a CFG of the sort:@@ -143,15 +188,11 @@   While E does not follow X it's still beneficial to place them near each other.   This can be advantageous if eg C,X,E will end up in the same cache line. -  TODO: If we remove edges as we use them (eg if we build up A->B remove A->B-        from the list) we could save some more work in later phases.--   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~   ~~~ Note [Triangle Control Flow]   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -  Checking if an argument is already evaluating leads to a somewhat+  Checking if an argument is already evaluated leads to a somewhat   special case  which looks like this:      A:@@ -206,53 +247,39 @@ neighbourOverlapp :: Int neighbourOverlapp = 2 --- | Only edges heavier than this are considered---   for fusing two chains into a single chain.-fuseEdgeThreshold :: EdgeWeight-fuseEdgeThreshold = 0-+-- | Maps blocks near the end of a chain to it's chain AND+-- the other blocks near the end.+-- [A,B,C,D,E] Gives entries like (B -> ([A,B], [A,B,C,D,E]))+-- where [A,B] are blocks in the end region of a chain.+-- This is cheaper then recomputing the ends multiple times.+type FrontierMap = LabelMap ([BlockId],BlockChain)  -- | A non empty ordered sequence of basic blocks. --   It is suitable for serialization in this order.-data BlockChain-    = BlockChain-    { chainMembers :: !LabelSet-    , chainBlocks :: !BlockSequence-    }--instance Eq (BlockChain) where-    (BlockChain s1 _) == (BlockChain s2 _)-        = s1 == s2--instance Outputable (BlockChain) where-    ppr (BlockChain _ blks) =-        parens (text "Chain:" <+> ppr (seqToList $ blks) )+--+--   We use OrdList instead of [] to allow fast append on both sides+--   when combining chains.+newtype BlockChain+    = BlockChain { chainBlocks :: (OrdList BlockId) } -data WeightedEdge = WeightedEdge !BlockId !BlockId EdgeWeight deriving (Eq)+-- All chains are constructed the same way so comparison+-- including structure is faster.+instance Eq BlockChain where+    BlockChain b1 == BlockChain b2 = strictlyEqOL b1 b2  -- Useful for things like sets and debugging purposes, sorts by blocks -- in the chain. instance Ord (BlockChain) where-   (BlockChain lbls1 _) `compare` (BlockChain lbls2 _)-       = lbls1 `compare` lbls2---- | Non deterministic! (Uniques) Sorts edges by weight and nodes.-instance Ord WeightedEdge where-  compare (WeightedEdge from1 to1 weight1)-          (WeightedEdge from2 to2 weight2)-    | weight1 < weight2 || weight1 == weight2 && from1 < from2 ||-      weight1 == weight2 && from1 == from2 && to1 < to2-    = LT-    | from1 == from2 && to1 == to2 && weight1 == weight2-    = EQ-    | otherwise-    = GT+   (BlockChain lbls1) `compare` (BlockChain lbls2)+       = ASSERT(toList lbls1 /= toList lbls2 || lbls1 `strictlyEqOL` lbls2)+         strictlyOrdOL lbls1 lbls2 -instance Outputable WeightedEdge where-    ppr (WeightedEdge from to info) =-        ppr from <> text "->" <> ppr to <> brackets (ppr info)+instance Outputable (BlockChain) where+    ppr (BlockChain blks) =+        parens (text "Chain:" <+> ppr (fromOL $ blks) ) -type WeightedEdgeList = [WeightedEdge]+chainFoldl :: (b -> BlockId -> b) -> b -> BlockChain -> b+chainFoldl f z (BlockChain blocks) = foldl' f z blocks  noDups :: [BlockChain] -> Bool noDups chains =@@ -262,102 +289,60 @@         else pprTrace "Duplicates:" (ppr (map toList dups) $$ text "chains" <+> ppr chains ) False  inFront :: BlockId -> BlockChain -> Bool-inFront bid (BlockChain _ seq)-  = seqFront seq == bid--chainMember :: BlockId -> BlockChain -> Bool-chainMember bid chain-  = setMember bid . chainMembers $ chain+inFront bid (BlockChain seq)+  = headOL seq == bid  chainSingleton :: BlockId -> BlockChain chainSingleton lbl-    = BlockChain (setSingleton lbl) (Singleton lbl)+    = BlockChain (unitOL lbl) +chainFromList :: [BlockId] -> BlockChain+chainFromList = BlockChain . toOL+ chainSnoc :: BlockChain -> BlockId -> BlockChain-chainSnoc (BlockChain lbls blks) lbl-  = BlockChain (setInsert lbl lbls) (seqSnoc blks lbl)+chainSnoc (BlockChain blks) lbl+  = BlockChain (blks `snocOL` lbl) +chainCons :: BlockId -> BlockChain -> BlockChain+chainCons lbl (BlockChain blks)+  = BlockChain (lbl `consOL` blks)+ chainConcat :: BlockChain -> BlockChain -> BlockChain-chainConcat (BlockChain lbls1 blks1) (BlockChain lbls2 blks2)-  = BlockChain (setUnion lbls1 lbls2) (blks1 `seqConcat` blks2)+chainConcat (BlockChain blks1) (BlockChain blks2)+  = BlockChain (blks1 `appOL` blks2)  chainToBlocks :: BlockChain -> [BlockId]-chainToBlocks (BlockChain _ blks) = seqToList blks+chainToBlocks (BlockChain blks) = fromOL blks  -- | Given the Chain A -> B -> C -> D and we break at C --   we get the two Chains (A -> B, C -> D) as result. breakChainAt :: BlockId -> BlockChain              -> (BlockChain,BlockChain)-breakChainAt bid (BlockChain lbls blks)-    | not (setMember bid lbls)+breakChainAt bid (BlockChain blks)+    | not (bid == head rblks)     = panic "Block not in chain"     | otherwise-    = let (lblks, rblks) = break (\lbl -> lbl == bid)-                                 (seqToList blks)-          --TODO: Remove old-          --lblSet :: [GenBasicBlock i] -> BlockChain-          --lblSet blks =-          --  setFromList-                --(map (\(BasicBlock lbl _) -> lbl) $ toList blks)-      in-      (BlockChain (setFromList lblks) (seqFromBids lblks),-       BlockChain (setFromList rblks) (seqFromBids rblks))+    = (BlockChain (toOL lblks),+       BlockChain (toOL rblks))+  where+    (lblks, rblks) = break (\lbl -> lbl == bid) (fromOL blks)  takeR :: Int -> BlockChain -> [BlockId]-takeR n (BlockChain _ blks) =-    take n . seqToRList $ blks-+takeR n (BlockChain blks) =+    take n . fromOLReverse $ blks  takeL :: Int -> BlockChain -> [BlockId]-takeL n (BlockChain _ blks) = --error "TODO: takeLn"-    take n . seqToList $ blks---- | For a given list of chains try to fuse chains with strong---   edges between them into a single chain.---   Returns the list of fused chains together with a set of---   used edges. The set of edges is indirectly encoded in the---   chains so doesn't need to be considered for later passes.-fuseChains :: WeightedEdgeList -> LabelMap BlockChain-           -> (LabelMap BlockChain, Set.Set WeightedEdge)-fuseChains weights chains-    = let fronts = mapFromList $-                    map (\chain -> (head $ takeL 1 chain,chain)) $-                    mapElems chains :: LabelMap BlockChain-          (chains', used, _) = applyEdges weights chains fronts Set.empty-      in (chains', used)-    where-        applyEdges :: WeightedEdgeList -> LabelMap BlockChain-                   -> LabelMap BlockChain -> Set.Set WeightedEdge-                   -> (LabelMap BlockChain, Set.Set WeightedEdge, LabelMap BlockChain)-        applyEdges [] chainsEnd chainsFront used-            = (chainsEnd, used, chainsFront)-        applyEdges (edge@(WeightedEdge from to w):edges) chainsEnd chainsFront used-            --Since we order edges descending by weight we can stop here-            | w <= fuseEdgeThreshold-            = ( chainsEnd, used, chainsFront)-            --Fuse the two chains-            | Just c1 <- mapLookup from chainsEnd-            , Just c2 <- mapLookup to chainsFront-            , c1 /= c2-            = let newChain = chainConcat c1 c2-                  front = head $ takeL 1 newChain-                  end = head $ takeR 1 newChain-                  chainsFront' = mapInsert front newChain $-                                 mapDelete to chainsFront-                  chainsEnd'   = mapInsert end newChain $-                                 mapDelete from chainsEnd-              in applyEdges edges chainsEnd' chainsFront'-                            (Set.insert edge used)-            | otherwise-            --Check next edge-            = applyEdges edges chainsEnd chainsFront used+takeL n (BlockChain blks) =+    take n . fromOL $ blks +-- Note [Combining neighborhood chains]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  -- See also Note [Chain based CFG serialization] -- We have the chains (A-B-C-D) and (E-F) and an Edge C->E. ----- While placing the later after the former doesn't result in sequential--- control flow it is still be benefical since block C and E might end+-- While placing the latter after the former doesn't result in sequential+-- control flow it is still benefical. As block C and E might end -- up in the same cache line. -- -- So we place these chains next to each other even if we can't fuse them.@@ -366,7 +351,7 @@ --             v --             - -> E -> F ... ----- Simple heuristic to chose which chains we want to combine:+-- A simple heuristic to chose which chains we want to combine: --   * Process edges in descending priority. --   * Check if there is a edge near the end of one chain which goes --     to a block near the start of another edge.@@ -376,20 +361,28 @@ -- us to find all edges between two chains, check the distance for all edges, -- rank them based on the distance and and only then we can select two chains -- to combine. Which would add a lot of complexity for little gain.+--+-- So instead we just rank by the strength of the edge and use the first pair we+-- find.  -- | For a given list of chains and edges try to combine chains with strong --   edges between them.-combineNeighbourhood :: WeightedEdgeList -> [BlockChain]-                     -> [BlockChain]+combineNeighbourhood  :: [CfgEdge] -- ^ Edges to consider+                      -> [BlockChain] -- ^ Current chains of blocks+                      -> ([BlockChain], Set.Set (BlockId,BlockId))+                      -- ^ Resulting list of block chains, and a set of edges which+                      -- were used to fuse chains and as such no longer need to be+                      -- considered. combineNeighbourhood edges chains     = -- pprTraceIt "Neigbours" $-      applyEdges edges endFrontier startFrontier+    --   pprTrace "combineNeighbours" (ppr edges) $+      applyEdges edges endFrontier startFrontier (Set.empty)     where         --Build maps from chain ends to chains         endFrontier, startFrontier :: FrontierMap         endFrontier =             mapFromList $ concatMap (\chain ->-                                let ends = getEnds chain+                                let ends = getEnds chain :: [BlockId]                                     entry = (ends,chain)                                 in map (\x -> (x,entry)) ends ) chains         startFrontier =@@ -397,14 +390,14 @@                                 let front = getFronts chain                                     entry = (front,chain)                                 in map (\x -> (x,entry)) front) chains-        applyEdges :: WeightedEdgeList -> FrontierMap -> FrontierMap-                   -> [BlockChain]-        applyEdges [] chainEnds _chainFronts =-            ordNub $ map snd $ mapElems chainEnds-        applyEdges ((WeightedEdge from to _w):edges) chainEnds chainFronts+        applyEdges :: [CfgEdge] -> FrontierMap -> FrontierMap -> Set.Set (BlockId, BlockId)+                   -> ([BlockChain], Set.Set (BlockId,BlockId))+        applyEdges [] chainEnds _chainFronts combined =+            (ordNub $ map snd $ mapElems chainEnds, combined)+        applyEdges ((CfgEdge from to _w):edges) chainEnds chainFronts combined             | Just (c1_e,c1) <- mapLookup from chainEnds             , Just (c2_f,c2) <- mapLookup to chainFronts-            , c1 /= c2 -- Avoid trying to concat a short chain with itself.+            , c1 /= c2 -- Avoid trying to concat a chain with itself.             = let newChain = chainConcat c1 c2                   newChainFrontier = getFronts newChain                   newChainEnds = getEnds newChain@@ -438,165 +431,299 @@                 --   text "fronts" <+> ppr newFronts $$                 --   text "ends" <+> ppr newEnds                 --   )-                 applyEdges edges newEnds newFronts+                 applyEdges edges newEnds newFronts (Set.insert (from,to) combined)             | otherwise-            = --pprTrace "noNeigbours" (ppr ()) $-              applyEdges edges chainEnds chainFronts+            = applyEdges edges chainEnds chainFronts combined          where          getFronts chain = takeL neighbourOverlapp chain         getEnds chain = takeR neighbourOverlapp chain +-- In the last stop we combine all chains into a single one.+-- Trying to place chains with strong edges next to each other.+mergeChains :: [CfgEdge] -> [BlockChain]+            -> (BlockChain)+mergeChains edges chains+    = -- pprTrace "combine" (ppr edges) $+      runST $ do+        let addChain m0 chain = do+                ref <- newSTRef chain+                return $ chainFoldl (\m' b -> mapInsert b ref m') m0 chain+        chainMap' <- foldM (\m0 c -> addChain m0 c) mapEmpty chains+        merge edges chainMap'+    where+        -- We keep a map from ALL blocks to their respective chain (sigh)+        -- This is required since when looking at an edge we need to find+        -- the associated chains quickly.+        -- We use a map of STRefs, maintaining a invariant of one STRef per chain.+        -- When merging chains we can update the+        -- STRef of one chain once (instead of writing to the map for each block).+        -- We then overwrite the STRefs for the other chain so there is again only+        -- a single STRef for the combined chain.+        -- The difference in terms of allocations saved is ~0.2% with -O so actually+        -- significant compared to using a regular map. +        merge :: forall s. [CfgEdge] -> LabelMap (STRef s BlockChain) -> ST s BlockChain+        merge [] chains = do+            chains' <- ordNub <$> (mapM readSTRef $ mapElems chains) :: ST s [BlockChain]+            return $ foldl' chainConcat (head chains') (tail chains')+        merge ((CfgEdge from to _):edges) chains+        --   | pprTrace "merge" (ppr (from,to) <> ppr chains) False+        --   = undefined+          | cFrom == cTo+          = merge edges chains+          | otherwise+          = do+            chains' <- mergeComb cFrom cTo+            merge edges chains'+          where+            mergeComb :: STRef s BlockChain -> STRef s BlockChain -> ST s (LabelMap (STRef s BlockChain))+            mergeComb refFrom refTo = do+                cRight <- readSTRef refTo+                chain <- pure chainConcat <*> readSTRef refFrom <*> pure cRight+                writeSTRef refFrom chain+                return $ chainFoldl (\m b -> mapInsert b refFrom m) chains cRight --- See [Chain based CFG serialization]-buildChains :: CFG -> [BlockId]-            -> ( LabelMap BlockChain  -- Resulting chains.+            cFrom = expectJust "mergeChains:chainMap:from" $ mapLookup from chains+            cTo = expectJust "mergeChains:chainMap:to"   $ mapLookup to   chains+++-- See Note [Chain based CFG serialization] for the general idea.+-- This creates and fuses chains at the same time for performance reasons.++-- Try to build chains from a list of edges.+-- Edges must be sorted **descending** by their priority.+-- Returns the constructed chains, along with all edges which+-- are irrelevant past this point, this information doesn't need+-- to be complete - it's only used to speed up the process.+-- An Edge is irrelevant if the ends are part of the same chain.+-- We say these edges are already linked+buildChains :: [CfgEdge] -> [BlockId]+            -> ( LabelMap BlockChain  -- Resulting chains, indexd by end if chain.                , Set.Set (BlockId, BlockId)) --List of fused edges.-buildChains succWeights blocks-  = let (_, fusedEdges, chains) = buildNext setEmpty mapEmpty blocks Set.empty-    in (chains, fusedEdges)+buildChains edges blocks+  = runST $ buildNext setEmpty mapEmpty mapEmpty edges Set.empty   where-    -- We keep a map from the last block in a chain to the chain itself.-    -- This we we can easily check if an block should be appened to an+    -- buildNext builds up chains from edges one at a time.++    -- We keep a map from the ends of chains to the chains.+    -- This we we can easily check if an block should be appended to an     -- existing chain!-    buildNext :: LabelSet-              -> LabelMap BlockChain -- Map from last element to chain.-              -> [BlockId] -- Blocks to place-              -> Set.Set (BlockId, BlockId)-              -> ( [BlockChain]  -- Placed Blocks-                 , Set.Set (BlockId, BlockId) --List of fused edges-                 , LabelMap BlockChain-                 )-    buildNext _placed chains [] linked =-        ([], linked, chains)-    buildNext placed chains (block:todo) linked-        | setMember block placed-        = buildNext placed chains todo linked+    -- We store them using STRefs so we don't have to rebuild the spine of both+    -- maps every time we update a chain.+    buildNext :: forall s. LabelSet+              -> LabelMap (STRef s BlockChain) -- Map from end of chain to chain.+              -> LabelMap (STRef s BlockChain) -- Map from start of chain to chain.+              -> [CfgEdge] -- Edges to check - ordered by decreasing weight+              -> Set.Set (BlockId, BlockId) -- Used edges+              -> ST s   ( LabelMap BlockChain -- Chains by end+                        , Set.Set (BlockId, BlockId) --List of fused edges+                        )+    buildNext placed _chainStarts chainEnds  [] linked = do+        ends' <- sequence $ mapMap readSTRef chainEnds :: ST s (LabelMap BlockChain)+        -- Any remaining blocks have to be made to singleton chains.+        -- They might be combined with other chains later on outside this function.+        let unplaced = filter (\x -> not (setMember x placed)) blocks+            singletons = map (\x -> (x,chainSingleton x)) unplaced :: [(BlockId,BlockChain)]+        return (foldl' (\m (k,v) -> mapInsert k v m) ends' singletons , linked)+    buildNext placed chainStarts chainEnds (edge:todo) linked+        | from == to+        -- We skip self edges+        = buildNext placed chainStarts chainEnds todo (Set.insert (from,to) linked)+        | not (alreadyPlaced from) &&+          not (alreadyPlaced to)+        = do+            --pprTraceM "Edge-Chain:" (ppr edge)+            chain' <- newSTRef $ chainFromList [from,to]+            buildNext+                (setInsert to (setInsert from placed))+                (mapInsert from chain' chainStarts)+                (mapInsert to chain' chainEnds)+                todo+                (Set.insert (from,to) linked)++        | (alreadyPlaced from) &&+          (alreadyPlaced to)+        , Just predChain <- mapLookup from chainEnds+        , Just succChain <- mapLookup to chainStarts+        , predChain /= succChain -- Otherwise we try to create a cycle.+        = do+            -- pprTraceM "Fusing edge" (ppr edge)+            fuseChain predChain succChain++        | (alreadyPlaced from) &&+          (alreadyPlaced to)+        =   --pprTraceM "Skipping:" (ppr edge) >>+            buildNext placed chainStarts chainEnds todo linked+         | otherwise-        = buildNext placed' chains' todo linked'+        = do -- pprTraceM "Finding chain for:" (ppr edge $$+             --         text "placed" <+> ppr placed)+             findChain       where-        placed' = (foldl' (flip setInsert) placed placedBlocks)-        linked' = Set.union linked linkedEdges-        (placedBlocks, chains', linkedEdges) = findChain block+        from = edgeFrom edge+        to   = edgeTo   edge+        alreadyPlaced blkId = (setMember blkId placed) -        --Add the block to a existing or new chain-        --Returns placed blocks, list of resulting chains-        --and fused edges-        findChain :: BlockId-                -> ([BlockId],LabelMap BlockChain, Set.Set (BlockId, BlockId))-        findChain block-        -- B) place block at end of existing chain if-        -- there is no better block to append.-          | (pred:_) <- preds-          , alreadyPlaced pred-          , Just predChain <- mapLookup pred chains-          , (best:_) <- filter (not . alreadyPlaced) $ getSuccs pred-          , best == lbl-          = --pprTrace "B.2)" (ppr (pred,lbl)) $-            let newChain = chainSnoc predChain block-                chainMap = mapInsert lbl newChain $ mapDelete pred chains-            in  ( [lbl]-                , chainMap-                , Set.singleton (pred,lbl) )+        -- Combine two chains into a single one.+        fuseChain :: STRef s BlockChain -> STRef s BlockChain+                  -> ST s   ( LabelMap BlockChain -- Chains by end+                            , Set.Set (BlockId, BlockId) --List of fused edges+                            )+        fuseChain fromRef toRef = do+            fromChain <- readSTRef fromRef+            toChain <- readSTRef toRef+            let newChain = chainConcat fromChain toChain+            ref <- newSTRef newChain+            let start = head $ takeL 1 newChain+            let end = head $ takeR 1 newChain+            -- chains <- sequence $ mapMap readSTRef chainStarts+            -- pprTraceM "pre-fuse chains:" $ ppr chains+            buildNext+                placed+                (mapInsert start ref $ mapDelete to $ chainStarts)+                (mapInsert end ref $ mapDelete from $ chainEnds)+                todo+                (Set.insert (from,to) linked) ++        --Add the block to a existing chain or creates a new chain+        findChain :: ST s   ( LabelMap BlockChain -- Chains by end+                            , Set.Set (BlockId, BlockId) --List of fused edges+                            )+        findChain+          -- We can attach the block to the end of a chain+          | alreadyPlaced from+          , Just predChain <- mapLookup from chainEnds+          = do+            chain <- readSTRef predChain+            let newChain = chainSnoc chain to+            writeSTRef predChain newChain+            let chainEnds' = mapInsert to predChain $ mapDelete from chainEnds+            -- chains <- sequence $ mapMap readSTRef chainStarts+            -- pprTraceM "from chains:" $ ppr chains+            buildNext (setInsert to placed) chainStarts chainEnds' todo (Set.insert (from,to) linked)+          -- We can attack it to the front of a chain+          | alreadyPlaced to+          , Just succChain <- mapLookup to chainStarts+          = do+            chain <- readSTRef succChain+            let newChain = from `chainCons` chain+            writeSTRef succChain newChain+            let chainStarts' = mapInsert from succChain $ mapDelete to chainStarts+            -- chains <- sequence $ mapMap readSTRef chainStarts'+            -- pprTraceM "to chains:" $ ppr chains+            buildNext (setInsert from placed) chainStarts' chainEnds todo (Set.insert (from,to) linked)+          -- The placed end of the edge is part of a chain already and not an end.           | otherwise-          = --pprTrace "single" (ppr lbl)-            ( [lbl]-            , mapInsert lbl (chainSingleton lbl) chains-            , Set.empty)+          = do+            let block    = if alreadyPlaced to then from else to+            --pprTraceM "Singleton" $ ppr block+            let newChain = chainSingleton block+            ref <- newSTRef newChain+            buildNext (setInsert block placed) (mapInsert block ref chainStarts)+                      (mapInsert block ref chainEnds) todo (linked)             where               alreadyPlaced blkId = (setMember blkId placed)-              lbl = block-              getSuccs = map fst . getSuccEdgesSorted succWeights-              preds = map fst $ getSuccEdgesSorted predWeights lbl-    --For efficiency we also create the map to look up predecessors here-    predWeights = reverseEdges succWeights ----- We make the CFG a Hoopl Graph, so we can reuse revPostOrder.-newtype BlockNode e x = BN (BlockId,[BlockId])-instance NonLocal (BlockNode) where-  entryLabel (BN (lbl,_))   = lbl-  successors (BN (_,succs)) = succs--fromNode :: BlockNode C C -> BlockId-fromNode (BN x) = fst x--sequenceChain :: forall a i. (Instruction i, Outputable i) => LabelMap a -> CFG-            -> [GenBasicBlock i] -> [GenBasicBlock i]+-- | Place basic blocks based on the given CFG.+-- See Note [Chain based CFG serialization]+sequenceChain :: forall a i. (Instruction i, Outputable i)+              => LabelMap a -- ^ Keys indicate an info table on the block.+              -> CFG -- ^ Control flow graph and some meta data.+              -> [GenBasicBlock i] -- ^ List of basic blocks to be placed.+              -> [GenBasicBlock i] -- ^ Blocks placed in sequence. sequenceChain _info _weights    [] = [] sequenceChain _info _weights    [x] = [x] sequenceChain  info weights'     blocks@((BasicBlock entry _):_) =-    --Optimization, delete edges of weight <= 0.-    --This significantly improves performance whenever-    --we iterate over all edges, which is a few times!     let weights :: CFG-        weights-            = filterEdges (\_f _t edgeInfo -> edgeWeight edgeInfo > 0) weights'+        weights = --pprTrace "cfg'" (pprEdgeWeights cfg')+                  cfg'+          where+            (_, globalEdgeWeights) = {-# SCC mkGlobalWeights #-} mkGlobalWeights entry weights'+            cfg' = {-# SCC rewriteEdges #-}+                    mapFoldlWithKey+                        (\cfg from m ->+                            mapFoldlWithKey+                                (\cfg to w -> setEdgeWeight cfg (EdgeWeight w) from to )+                                cfg m )+                        weights'+                        globalEdgeWeights++        directEdges :: [CfgEdge]+        directEdges = sortBy (flip compare) $ catMaybes . map relevantWeight $ (infoEdgeList weights)+          where+            relevantWeight :: CfgEdge -> Maybe CfgEdge+            relevantWeight edge@(CfgEdge from to edgeInfo)+                | (EdgeInfo CmmSource { trans_cmmNode = CmmCall {} } _) <- edgeInfo+                -- Ignore edges across calls+                = Nothing+                | mapMember to info+                , w <- edgeWeight edgeInfo+                -- The payoff is small if we jump over an info table+                = Just (CfgEdge from to edgeInfo { edgeWeight = w/8 })+                | otherwise+                = Just edge+         blockMap :: LabelMap (GenBasicBlock i)         blockMap             = foldl' (\m blk@(BasicBlock lbl _ins) ->                         mapInsert lbl blk m)                      mapEmpty blocks -        toNode :: BlockId -> BlockNode C C-        toNode bid =-            -- sorted such that heavier successors come first.-            BN (bid,map fst . getSuccEdgesSorted weights' $ bid)--        orderedBlocks :: [BlockId]-        orderedBlocks-            = map fromNode $-              revPostorderFrom (fmap (toNode . blockId) blockMap) entry-         (builtChains, builtEdges)             = {-# SCC "buildChains" #-}               --pprTraceIt "generatedChains" $-              --pprTrace "orderedBlocks" (ppr orderedBlocks) $-              buildChains weights orderedBlocks+              --pprTrace "blocks" (ppr (mapKeys blockMap)) $+              buildChains directEdges (mapKeys blockMap) -        rankedEdges :: WeightedEdgeList-        -- Sort edges descending, remove fused eges+        rankedEdges :: [CfgEdge]+        -- Sort descending by weight, remove fused edges         rankedEdges =-            map (\(from, to, weight) -> WeightedEdge from to weight) .-            filter (\(from, to, _)-                        -> not (Set.member (from,to) builtEdges)) .-            sortWith (\(_,_,w) -> - w) $ weightedEdgeList weights+            filter (\edge -> not (Set.member (edgeFrom edge,edgeTo edge) builtEdges)) $+            directEdges -        (fusedChains, fusedEdges)+        (neighbourChains, combined)             = ASSERT(noDups $ mapElems builtChains)-              {-# SCC "fuseChains" #-}-              --(pprTrace "RankedEdges" $ ppr rankedEdges) $-              --pprTraceIt "FusedChains" $-              fuseChains rankedEdges builtChains+              {-# SCC "groupNeighbourChains" #-}+            --   pprTraceIt "NeighbourChains" $+              combineNeighbourhood rankedEdges (mapElems builtChains) -        rankedEdges' =-            filter (\edge -> not $ Set.member edge fusedEdges) $ rankedEdges -        neighbourChains-            = ASSERT(noDups $ mapElems fusedChains)-              {-# SCC "groupNeighbourChains" #-}-              --pprTraceIt "ResultChains" $-              combineNeighbourhood rankedEdges' (mapElems fusedChains)+        allEdges :: [CfgEdge]+        allEdges = {-# SCC allEdges #-}+                   sortOn (relevantWeight) $ filter (not . deadEdge) $ (infoEdgeList weights)+          where+            deadEdge :: CfgEdge -> Bool+            deadEdge (CfgEdge from to _) = let e = (from,to) in Set.member e combined || Set.member e builtEdges+            relevantWeight :: CfgEdge -> EdgeWeight+            relevantWeight (CfgEdge _ _ edgeInfo)+                | EdgeInfo (CmmSource { trans_cmmNode = CmmCall {}}) _ <- edgeInfo+                -- Penalize edges across calls+                = weight/(64.0)+                | otherwise+                = weight+              where+                -- negate to sort descending+                weight = negate (edgeWeight edgeInfo) +        masterChain =+            {-# SCC "mergeChains" #-}+            -- pprTraceIt "MergedChains" $+            mergeChains allEdges neighbourChains+         --Make sure the first block stays first-        ([entryChain],chains')-            = ASSERT(noDups $ neighbourChains)-              partition (chainMember entry) neighbourChains-        (entryChain':entryRest)-            | inFront entry entryChain = [entryChain]-            | (rest,entry) <- breakChainAt entry entryChain+        prepedChains+            | inFront entry masterChain+            = [masterChain]+            | (rest,entry) <- breakChainAt entry masterChain             = [entry,rest]             | otherwise = pprPanic "Entry point eliminated" $-                            ppr ([entryChain],chains')+                            ppr masterChain -        prepedChains-            = entryChain':(entryRest++chains') :: [BlockChain]         blockList-            -- = (concatMap chainToBlocks prepedChains)-            = (concatMap seqToList $ map chainBlocks prepedChains)+            = ASSERT(noDups [masterChain])+              (concatMap fromOL $ map chainBlocks prepedChains)          --chainPlaced = setFromList $ map blockId blockList :: LabelSet         chainPlaced = setFromList $ blockList :: LabelSet@@ -606,14 +733,22 @@             in filter (\block -> not (isPlaced block)) blocks          placedBlocks =+            -- We want debug builds to catch this as it's a good indicator for+            -- issues with CFG invariants. But we don't want to blow up production+            -- builds if something slips through.+            ASSERT(null unplaced)             --pprTraceIt "placedBlocks" $-            blockList ++ unplaced+            -- ++ [] is stil kinda expensive+            if null unplaced then blockList else blockList ++ unplaced         getBlock bid = expectJust "Block placment" $ mapLookup bid blockMap     in         --Assert we placed all blocks given as input         ASSERT(all (\bid -> mapMember bid blockMap) placedBlocks)         dropJumps info $ map getBlock placedBlocks +{-# SCC dropJumps #-}+-- | Remove redundant jumps between blocks when we can rely on+-- fall through. dropJumps :: forall a i. Instruction i => LabelMap a -> [GenBasicBlock i]           -> [GenBasicBlock i] dropJumps _    [] = []@@ -664,7 +799,6 @@     dontUseCfg = gopt Opt_WeightlessBlocklayout dflags ||                  (not $ backendMaintainsCfg dflags) - -- The old algorithm: -- It is very simple (and stupid): We make a graph out of -- the blocks where there is an edge from one block to another iff the@@ -758,64 +892,3 @@     v <- lookupUFM m k     return (v, delFromUFM m k) --- ---------------------------------------------------------------------- Some specialized data structures to speed things up:---  * BlockSequence: A specialized version of Data.Sequence.---    Better at indexing at the front/end but lacks ability---    to do lookup by position.--type FrontierMap = LabelMap ([BlockId],BlockChain)---- | A "reverse zipper" of sorts.--- We store a list of blocks in two parts, the initial part from left to right--- and the remaining part stored in reverse order. This makes it easy to look--- the last/first element and append on both sides.-data BlockSequence-  = Singleton !BlockId-  | Pair (OrdList BlockId) (OrdList BlockId)-    -- ^ For a non empty pair there is at least one element in the left part.-  | Empty--seqFront :: BlockSequence -> BlockId-seqFront Empty = panic "Empty sequence"-seqFront (Singleton bid) = bid-seqFront (Pair lefts rights) = expectJust "Seq invariant" $-    listToMaybe (fromOL lefts) <|> listToMaybe (fromOL $ reverseOL rights)---- seqEnd :: BlockSequence -> BlockId--- seqEnd Empty = panic "Empty sequence"--- seqEnd (Singleton bid) = bid--- seqEnd (Pair lefts rights) = expectJust "Seq invariant" $---     listToMaybe (fromOL rights) <|> listToMaybe (fromOL $ reverseOL lefts)--seqToList :: BlockSequence -> [BlockId]-seqToList Empty = []-seqToList (Singleton bid) = [bid]-seqToList (Pair lefts rights) = fromOL $ lefts `appOL` reverseOL rights---seqToRList :: BlockSequence -> [BlockId]-seqToRList Empty = []-seqToRList (Singleton bid) = [bid]-seqToRList (Pair lefts rights) = fromOL $ rights `appOL` reverseOL lefts--seqSnoc :: BlockSequence -> BlockId -> BlockSequence-seqSnoc (Empty) bid = Singleton bid-seqSnoc (Singleton s) bid= Pair (unitOL s) (unitOL bid)-seqSnoc (Pair lefts rights) bid = Pair lefts (bid `consOL` rights)--seqConcat :: BlockSequence -> BlockSequence -> BlockSequence-seqConcat (Empty) x2 = x2-seqConcat (Singleton b1) (Singleton b2) = Pair (unitOL b1) (unitOL b2)-seqConcat x1 (Empty) = x1-seqConcat (Singleton b1) (Pair lefts rights) = Pair (b1 `consOL` lefts) rights-seqConcat (Pair lefts rights) (Singleton b2) = Pair lefts (b2 `consOL` rights)-seqConcat (Pair lefts1 rights1) (Pair lefts2 rights2) =-    Pair (lefts1 `appOL` (reverseOL rights1) `appOL` lefts2) rights2--seqFromBids :: [BlockId] -> BlockSequence-seqFromBids [] = Empty-seqFromBids [b1] = Singleton b1-seqFromBids [b1,b2] = Pair (unitOL b1) (unitOL b2)-seqFromBids [b1,b2,b3] = Pair (consOL b1 $ unitOL b2) (unitOL b3)-seqFromBids (b1:b2:b3:bs) = Pair (toOL [b1,b2,b3]) (toOL bs)
compiler/nativeGen/CFG.hs view
@@ -6,41 +6,49 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}  module CFG     ( CFG, CfgEdge(..), EdgeInfo(..), EdgeWeight(..)     , TransitionSource(..)      --Modify the CFG-    , addWeightEdge, addEdge, delEdge+    , addWeightEdge, addEdge+    , delEdge, delNode     , addNodesBetween, shortcutWeightMap     , reverseEdges, filterEdges     , addImmediateSuccessor-    , mkWeightInfo, adjustEdgeWeight+    , mkWeightInfo, adjustEdgeWeight, setEdgeWeight      --Query the CFG     , infoEdgeList, edgeList     , getSuccessorEdges, getSuccessors-    , getSuccEdgesSorted, weightedEdgeList+    , getSuccEdgesSorted     , getEdgeInfo     , getCfgNodes, hasNode-    , loopMembers +    -- Loop Information+    , loopMembers, loopLevels, loopInfo+     --Construction/Misc     , getCfg, getCfgProc, pprEdgeWeights, sanityCheckCfg      --Find backedges and update their weight-    , optimizeCFG )+    , optimizeCFG+    , mkGlobalWeights++     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import BlockId-import Cmm ( RawCmmDecl, GenCmmDecl( .. ), CmmBlock, succ, g_entry-           , CmmGraph )-import CmmNode+import Cmm+ import CmmUtils import CmmSwitch import Hoopl.Collections@@ -50,26 +58,52 @@  import Util import Digraph+import Maybes +import Unique+import qualified Dominators as Dom+import Data.IntMap.Strict (IntMap)+import Data.IntSet (IntSet)++import qualified Data.IntMap.Strict as IM+import qualified Data.Map as M+import qualified Data.IntSet as IS+import qualified Data.Set as S+import Data.Tree+import Data.Bifunctor+ import Outputable -- DEBUGGING ONLY --import Debug+-- import Debug.Trace --import OrdList --import Debug.Trace-import PprCmm ()+import PprCmm () -- For Outputable instances import qualified DynFlags as D -import Data.List+import Data.List (sort, nub, partition)+import Data.STRef.Strict+import Control.Monad.ST +import Data.Array.MArray+import Data.Array.ST+import Data.Array.IArray+import Data.Array.Unsafe (unsafeFreeze)+import Data.Array.Base (unsafeRead, unsafeWrite)++import Control.Monad++type Prob = Double+ type Edge = (BlockId, BlockId) type Edges = [Edge]  newtype EdgeWeight-  = EdgeWeight Int-  deriving (Eq,Ord,Enum,Num,Real,Integral)+  = EdgeWeight { weightToDouble :: Double }+  deriving (Eq,Ord,Enum,Num,Real,Fractional)  instance Outputable EdgeWeight where-  ppr (EdgeWeight w) = ppr w+  ppr (EdgeWeight w) = doublePrec 5 w  type EdgeInfoMap edgeInfo = LabelMap (LabelMap edgeInfo) @@ -113,15 +147,28 @@     = parens (ppr from1 <+> text "-(" <> ppr edgeInfo <> text ")->" <+> ppr to1)  -- | Can we trace back a edge to a specific Cmm Node--- or has it been introduced for codegen. We use this to maintain+-- or has it been introduced during assembly codegen. We use this to maintain -- some information which would otherwise be lost during the -- Cmm <-> asm transition. -- See also Note [Inverting Conditional Branches] data TransitionSource-  = CmmSource (CmmNode O C)+  = CmmSource { trans_cmmNode :: (CmmNode O C)+              , trans_info :: BranchInfo }   | AsmCodeGen   deriving (Eq) +data BranchInfo = NoInfo         -- ^ Unknown, but not heap or stack check.+                | HeapStackCheck -- ^ Heap or stack check+    deriving Eq++instance Outputable BranchInfo where+    ppr NoInfo = text "regular"+    ppr HeapStackCheck = text "heap/stack"++isHeapOrStackCheck :: TransitionSource -> Bool+isHeapOrStackCheck (CmmSource { trans_info = HeapStackCheck}) = True+isHeapOrStackCheck _ = False+ -- | Information about edges data EdgeInfo   = EdgeInfo@@ -132,12 +179,10 @@ instance Outputable EdgeInfo where   ppr edgeInfo = text "weight:" <+> ppr (edgeWeight edgeInfo) --- Allow specialization-{-# INLINEABLE mkWeightInfo #-} -- | Convenience function, generate edge info based --   on weight not originating from cmm.-mkWeightInfo :: Integral n => n -> EdgeInfo-mkWeightInfo = EdgeInfo AsmCodeGen . fromIntegral+mkWeightInfo :: EdgeWeight -> EdgeInfo+mkWeightInfo = EdgeInfo AsmCodeGen  -- | Adjust the weight between the blocks using the given function. --   If there is no such edge returns the original map.@@ -145,14 +190,25 @@                  -> BlockId -> BlockId -> CFG adjustEdgeWeight cfg f from to   | Just info <- getEdgeInfo from to cfg-  , weight <- edgeWeight info-  = addEdge from to (info { edgeWeight = f weight}) cfg+  , !weight <- edgeWeight info+  , !newWeight <- f weight+  = addEdge from to (info { edgeWeight = newWeight}) cfg   | otherwise = cfg +-- | Set the weight between the blocks to the given weight.+--   If there is no such edge returns the original map.+setEdgeWeight :: CFG -> EdgeWeight+              -> BlockId -> BlockId -> CFG+setEdgeWeight cfg !weight from to+  | Just info <- getEdgeInfo from to cfg+  = addEdge from to (info { edgeWeight = weight}) cfg+  | otherwise = cfg -getCfgNodes :: CFG -> LabelSet-getCfgNodes m = mapFoldMapWithKey (\k v -> setFromList (k:mapKeys v)) m +getCfgNodes :: CFG -> [BlockId]+getCfgNodes m =+    mapKeys m+ -- | Is this block part of this graph? hasNode :: CFG -> BlockId -> Bool hasNode m node =@@ -178,7 +234,7 @@             msg )             False     where-      cfgNodes = getCfgNodes m :: LabelSet+      cfgNodes = setFromList $ getCfgNodes m :: LabelSet       diff = (setUnion cfgNodes blockSet) `setDifference` (setIntersection cfgNodes blockSet) :: LabelSet  -- | Filter the CFG with a custom function f.@@ -273,7 +329,7 @@ --             \                  \ --              -> C    =>         -> C ---addImmediateSuccessor :: HasDebugCallStack => BlockId -> BlockId -> CFG -> CFG+addImmediateSuccessor :: BlockId -> BlockId -> CFG -> CFG addImmediateSuccessor node follower cfg     = updateEdges . addWeightEdge node follower uncondWeight $ cfg     where@@ -295,7 +351,7 @@         -- 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+        -- We must add the destination node explicitly         addDestNode Nothing = Just $ mapEmpty         addDestNode n@(Just _) = n @@ -314,6 +370,11 @@         remDest Nothing = Nothing         remDest (Just wm) = Just $ mapDelete to wm +delNode :: BlockId -> CFG -> CFG+delNode node cfg =+  fmap (mapDelete node)  -- < Edges to the node+    (mapDelete node cfg) -- < Edges from the node+ -- | Destinations from bid ordered by weight (descending) getSuccEdgesSorted :: CFG -> BlockId -> [(BlockId,EdgeInfo)] getSuccEdgesSorted m bid =@@ -328,7 +389,7 @@ getSuccessorEdges m bid = maybe lookupError mapToList (mapLookup bid m)   where     lookupError = pprPanic "getSuccessorEdges: Block does not exist" $-                    ppr bid $$ text "CFG:" <+> pprEdgeWeights m+                    ppr bid <+> pprEdgeWeights m  getEdgeInfo :: BlockId -> BlockId -> CFG -> Maybe EdgeInfo getEdgeInfo from to m@@ -338,37 +399,54 @@     | otherwise     = Nothing +getEdgeWeight :: CFG -> BlockId -> BlockId -> EdgeWeight+getEdgeWeight cfg from to =+    edgeWeight $ expectJust "Edgeweight for noexisting block" $+                 getEdgeInfo from to cfg++getTransitionSource :: BlockId -> BlockId -> CFG -> TransitionSource+getTransitionSource from to cfg = transitionSource $ expectJust "Source info for noexisting block" $+                        getEdgeInfo from to cfg+ reverseEdges :: CFG -> CFG reverseEdges cfg = mapFoldlWithKey (\cfg from toMap -> go (addNode cfg from) from toMap) mapEmpty cfg   where-    -- We preserve nodes without outgoing edges!+    -- We must 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] infoEdgeList m =-  mapFoldMapWithKey-    (\from toMap ->-      map (\(to,info) -> CfgEdge from to info) (mapToList toMap))-    m---- | Unordered list of edges with weight as Tuple (from,to,weight)-weightedEdgeList :: CFG -> [(BlockId,BlockId,EdgeWeight)]-weightedEdgeList m =-  mapFoldMapWithKey-    (\from toMap ->-      map (\(to,info) ->-        (from,to, edgeWeight info)) (mapToList toMap))-    m-      --  (\(from, tos) -> map (\(to,info) -> (from,to, edgeWeight info)) tos )+    go (mapToList m) []+  where+    -- We avoid foldMap to avoid thunk buildup+    go :: [(BlockId,LabelMap EdgeInfo)] -> [CfgEdge] -> [CfgEdge]+    go [] acc = acc+    go ((from,toMap):xs) acc+      = go' xs from (mapToList toMap) acc+    go' :: [(BlockId,LabelMap EdgeInfo)] -> BlockId -> [(BlockId,EdgeInfo)] -> [CfgEdge] -> [CfgEdge]+    go' froms _    []              acc = go froms acc+    go' froms from ((to,info):tos) acc+      = go' froms from tos (CfgEdge from to info : acc)  -- | Returns a unordered list of all edges without weights edgeList :: CFG -> [Edge] edgeList m =-        mapFoldMapWithKey (\from toMap -> fmap (from,) (mapKeys toMap)) m+    go (mapToList m) []+  where+    -- We avoid foldMap to avoid thunk buildup+    go :: [(BlockId,LabelMap EdgeInfo)] -> [Edge] -> [Edge]+    go [] acc = acc+    go ((from,toMap):xs) acc+      = go' xs from (mapKeys toMap) acc+    go' :: [(BlockId,LabelMap EdgeInfo)] -> BlockId -> [BlockId] -> [Edge] -> [Edge]+    go' froms _    []              acc = go froms acc+    go' froms from (to:tos) acc+      = go' froms from tos ((from,to) : acc)  -- | Get successors of a given node without edge weights. getSuccessors :: HasDebugCallStack => CFG -> BlockId -> [BlockId]@@ -382,8 +460,8 @@  pprEdgeWeights :: CFG -> SDoc pprEdgeWeights m =-    let edges = sort $ weightedEdgeList m-        printEdge (from, to, weight)+    let edges = sort $ infoEdgeList m :: [CfgEdge]+        printEdge (CfgEdge from to (EdgeInfo { edgeWeight = weight }))             = text "\t" <> ppr from <+> text "->" <+> ppr to <>               text "[label=\"" <> ppr weight <> text "\",weight=\"" <>               ppr weight <> text "\"];\n"@@ -392,7 +470,7 @@         --to immediately see it when it does.         printNode node             = text "\t" <> ppr node <> text ";\n"-        getEdgeNodes (from, to, _weight) = [from,to]+        getEdgeNodes (CfgEdge from to _) = [from,to]         edgeNodes = setFromList $ concatMap getEdgeNodes edges :: LabelSet         nodes = filter (\n -> (not . setMember n) edgeNodes) . mapKeys $ mapFilter null m     in@@ -406,8 +484,8 @@ updateEdgeWeight :: (EdgeWeight -> EdgeWeight) -> Edge -> CFG -> CFG updateEdgeWeight f (from, to) cfg     | Just oldInfo <- getEdgeInfo from to cfg-    = let oldWeight = edgeWeight oldInfo-          newWeight = f oldWeight+    = let !oldWeight = edgeWeight oldInfo+          !newWeight = f oldWeight       in addEdge from to (oldInfo {edgeWeight = newWeight}) cfg     | otherwise     = panic "Trying to update invalid edge"@@ -476,9 +554,7 @@    Should A or B be placed in front of C? The block layout algorithm   decides this based on which edge (A,C)/(B,C) is heavier. So we-  make a educated guess how often execution will transer control-  along each edge as well as how much we gain by placing eg A before-  C.+  make a educated guess on which branch should be preferred.    We rank edges in this order:   * Unconditional Control Transfer - They will always@@ -507,17 +583,11 @@           address. This reduces the chance that we return to the same           cache line further. - -} -- | Generate weights for a Cmm proc based on some simple heuristics. getCfgProc :: D.CfgWeights -> RawCmmDecl -> CFG getCfgProc _       (CmmData {}) = mapEmpty--- Sometimes GHC generates dummy procs which don't actually contain code.--- But they might contain bottoms in some fields so we check for an empty--- body first. In particular this happens with SplitObjs enabled.-getCfgProc weights (CmmProc _info _lab _live graph)-  | null (toBlockList graph) = mapEmpty-  | otherwise                = getCfg weights graph+getCfgProc weights (CmmProc _info _lab _live graph) = getCfg weights graph  getCfg :: D.CfgWeights -> CmmGraph -> CFG getCfg weights graph =@@ -548,13 +618,24 @@     getBlockEdges block =       case branch of         CmmBranch dest -> [mkEdge dest uncondWeight]-        CmmCondBranch _c t f l+        CmmCondBranch cond t f l           | l == Nothing ->               [mkEdge f condBranchWeight,   mkEdge t condBranchWeight]           | l == Just True ->               [mkEdge f unlikelyCondWeight, mkEdge t likelyCondWeight]           | l == Just False ->               [mkEdge f likelyCondWeight,   mkEdge t unlikelyCondWeight]+          where+            mkEdgeInfo = -- pprTrace "Info" (ppr branchInfo <+> ppr cond)+                         EdgeInfo (CmmSource branch branchInfo) . fromIntegral+            mkEdge target weight = ((bid,target), mkEdgeInfo weight)+            branchInfo =+              foldRegsUsed+                (panic "foldRegsDynFlags")+                (\info r -> if r == SpLim || r == HpLim || r == BaseReg+                    then HeapStackCheck else info)+                NoInfo cond+         (CmmSwitch _e ids) ->           let switchTargets = switchTargetsToList ids               --Compiler performance hack - for very wide switches don't@@ -572,7 +653,7 @@             map (\x -> ((bid,x),mkEdgeInfo 0)) $ G.successors other       where         bid = G.entryLabel block-        mkEdgeInfo = EdgeInfo (CmmSource branch) . fromIntegral+        mkEdgeInfo = EdgeInfo (CmmSource branch NoInfo) . fromIntegral         mkEdge target weight = ((bid,target), mkEdgeInfo weight)         branch = lastNode block :: CmmNode O C @@ -591,9 +672,14 @@       classifyEdges root getSuccs edges :: [((BlockId,BlockId),EdgeType)]  -optimizeCFG :: HasDebugCallStack => D.CfgWeights -> RawCmmDecl -> CFG -> CFG+optimizeCFG :: D.CfgWeights -> RawCmmDecl -> CFG -> CFG optimizeCFG _ (CmmData {}) cfg = cfg optimizeCFG weights (CmmProc info _lab _live graph) cfg =+    {-# SCC optimizeCFG #-}+    -- pprTrace "Initial:" (pprEdgeWeights cfg) $+    -- pprTrace "Initial:" (ppr $ mkGlobalWeights (g_entry graph) cfg) $++    -- pprTrace "LoopInfo:" (ppr $ loopInfo cfg (g_entry graph)) $     favourFewerPreds  .     penalizeInfoTables info .     increaseBackEdgeWeight (g_entry graph) $ cfg@@ -623,12 +709,8 @@           = weight - (fromIntegral $ D.infoTablePenalty weights)           | otherwise = weight --{- Note [Optimize for Fallthrough]---}     -- | If a block has two successors, favour the one with fewer-    -- predecessors. (As that one is more likely to become a fallthrough)+    -- predecessors and/or the one allowing fall through.     favourFewerPreds :: CFG -> CFG     favourFewerPreds cfg =         let@@ -645,38 +727,38 @@               | preds1 == preds2 = ( 0, 0)               | otherwise        = (-1, 1) +            update :: CFG -> BlockId -> CFG             update cfg node               | [(s1,e1),(s2,e2)] <- getSuccessorEdges cfg node-              , w1 <- edgeWeight e1-              , w2 <- edgeWeight e2+              , !w1 <- edgeWeight e1+              , !w2 <- edgeWeight e2               --Only change the weights if there isn't already a ordering.               , w1 == w2               , (mod1,mod2) <- modifiers (predCount s1) (predCount s2)               = (\cfg' ->                   (adjustEdgeWeight cfg' (+mod2) node s2))-                  (adjustEdgeWeight cfg  (+mod1) node s1)+                    (adjustEdgeWeight cfg  (+mod1) node s1)               | otherwise               = cfg-        in setFoldl update cfg nodes+        in foldl' update cfg nodes       where         fallthroughTarget :: BlockId -> EdgeInfo -> Bool         fallthroughTarget to (EdgeInfo source _weight)           | mapMember to info = False           | AsmCodeGen <- source = True-          | CmmSource (CmmBranch {}) <- source = True-          | CmmSource (CmmCondBranch {}) <- source = True+          | CmmSource { trans_cmmNode = CmmBranch {} } <- source = True+          | CmmSource { trans_cmmNode = CmmCondBranch {} } <- source = True           | otherwise = False  -- | 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.+--   This is faster but only gives yes/no answers. 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 (getCfgNodes cfg)      sccs = stronglyConnCompFromEdgedVerticesOrd nodes @@ -684,3 +766,556 @@     setLevel (AcyclicSCC bid) m = mapInsert bid False m     setLevel (CyclicSCC bids) m = foldl' (\m k -> mapInsert k True m) m bids +loopLevels :: CFG -> BlockId -> LabelMap Int+loopLevels cfg root = liLevels loopInfos+    where+      loopInfos = loopInfo cfg root++data LoopInfo = LoopInfo+  { liBackEdges :: [(Edge)] -- ^ List of back edges+  , liLevels :: LabelMap Int -- ^ BlockId -> LoopLevel mapping+  , liLoops :: [(Edge, LabelSet)] -- ^ (backEdge, loopBody), body includes header+  }++instance Outputable LoopInfo where+    ppr (LoopInfo _ _lvls loops) =+        text "Loops:(backEdge, bodyNodes)" $$+            (vcat $ map ppr loops)++{-  Note [Determining the loop body]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++    Starting with the knowledge that:+    * head dominates the loop+    * `tail` -> `head` is a backedge++    We can determine all nodes by:+    * Deleting the loop head from the graph.+    * Collect all blocks which are reachable from the `tail`.++    We do so by performing bfs from the tail node towards the head.+ -}++-- | Determine loop membership of blocks based on Dominator analysis.+--   This is slower but gives loop levels instead of just loop membership.+--   However it only detects natural loops. Irreducible control flow is not+--   recognized even if it loops. But that is rare enough that we don't have+--   to care about that special case.+loopInfo :: HasDebugCallStack => CFG -> BlockId -> LoopInfo+loopInfo cfg root = LoopInfo  { liBackEdges = backEdges+                              , liLevels = mapFromList loopCounts+                              , liLoops = loopBodies }+  where+    revCfg = reverseEdges cfg++    graph = -- pprTrace "CFG - loopInfo" (pprEdgeWeights cfg) $+            fmap (setFromList . mapKeys ) cfg :: LabelMap LabelSet+++    --TODO - This should be a no op: Export constructors? Use unsafeCoerce? ...+    rooted = ( fromBlockId root+              , toIntMap $ fmap toIntSet graph) :: (Int, IntMap IntSet)+    tree = fmap toBlockId $ Dom.domTree rooted :: Tree BlockId++    -- Map from Nodes to their dominators+    domMap :: LabelMap LabelSet+    domMap = mkDomMap tree++    edges = edgeList cfg :: [(BlockId, BlockId)]+    -- We can't recompute nodes from edges, there might be blocks not connected via edges.+    nodes = getCfgNodes cfg :: [BlockId]++    -- identify back edges+    isBackEdge (from,to)+      | Just doms <- mapLookup from domMap+      , setMember to doms+      = True+      | otherwise = False++    -- See Note [Determining the loop body]+    -- Get the loop body associated with a back edge.+    findBody edge@(tail, head)+      = ( edge, setInsert head $ go (setSingleton tail) (setSingleton tail) )+      where+        -- See Note [Determining the loop body]+        cfg' = delNode head revCfg++        go :: LabelSet -> LabelSet -> LabelSet+        go found current+          | setNull current = found+          | otherwise = go  (setUnion newSuccessors found)+                            newSuccessors+          where+            -- Really predecessors, since we use the reversed cfg.+            newSuccessors = setFilter (\n -> not $ setMember n found) successors :: LabelSet+            successors = setFromList $ concatMap+                                      (getSuccessors cfg')+                                      -- we filter head as it's no longer part of the cfg.+                                      (filter (/= head) $ setElems current) :: LabelSet++    backEdges = filter isBackEdge edges+    loopBodies = map findBody backEdges :: [(Edge, LabelSet)]++    -- Block b is part of n loop bodies => loop nest level of n+    loopCounts =+      let bodies = map (first snd) loopBodies -- [(Header, Body)]+          loopCount n = length $ nub . map fst . filter (setMember n . snd) $ bodies+      in  map (\n -> (n, loopCount n)) $ nodes :: [(BlockId, Int)]++    toIntSet :: LabelSet -> IntSet+    toIntSet s = IS.fromList . map fromBlockId . setElems $ s+    toIntMap :: LabelMap a -> IntMap a+    toIntMap m = IM.fromList $ map (\(x,y) -> (fromBlockId x,y)) $ mapToList m++    mkDomMap :: Tree BlockId -> LabelMap LabelSet+    mkDomMap root = mapFromList $ go setEmpty root+      where+        go :: LabelSet -> Tree BlockId -> [(Label,LabelSet)]+        go parents (Node lbl [])+          =  [(lbl, parents)]+        go parents (Node _ leaves)+          = let nodes = map rootLabel leaves+                entries = map (\x -> (x,parents)) nodes+            in  entries ++ concatMap+                            (\n -> go (setInsert (rootLabel n) parents) n)+                            leaves++    fromBlockId :: BlockId -> Int+    fromBlockId = getKey . getUnique++    toBlockId :: Int -> BlockId+    toBlockId = mkBlockId . mkUniqueGrimily++-- We make the CFG a Hoopl Graph, so we can reuse revPostOrder.+newtype BlockNode (e :: Extensibility) (x :: Extensibility) = BN (BlockId,[BlockId])++instance G.NonLocal (BlockNode) where+  entryLabel (BN (lbl,_))   = lbl+  successors (BN (_,succs)) = succs++revPostorderFrom :: HasDebugCallStack => CFG -> BlockId -> [BlockId]+revPostorderFrom cfg root =+    map fromNode $ G.revPostorderFrom hooplGraph root+  where+    nodes = getCfgNodes cfg+    hooplGraph = foldl' (\m n -> mapInsert n (toNode n) m) mapEmpty nodes++    fromNode :: BlockNode C C -> BlockId+    fromNode (BN x) = fst x++    toNode :: BlockId -> BlockNode C C+    toNode bid =+        BN (bid,getSuccessors cfg $ bid)+++-- | We take in a CFG which has on its edges weights which are+--   relative only to other edges originating from the same node.+--+--   We return a CFG for which each edge represents a GLOBAL weight.+--   This means edge weights are comparable across the whole graph.+--+--   For irreducible control flow results might be imprecise, otherwise they+--   are reliable.+--+--   The algorithm is based on the Paper+--   "Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus+--   The only big change is that we go over the nodes in the body of loops in+--   reverse post order. Which is required for diamond control flow to work probably.+--+--   We also apply a few prediction heuristics (based on the same paper)++{-# NOINLINE mkGlobalWeights #-}+{-# SCC mkGlobalWeights #-}+mkGlobalWeights :: HasDebugCallStack => BlockId -> CFG -> (LabelMap Double, LabelMap (LabelMap Double))+mkGlobalWeights root localCfg+  | null localCfg = panic "Error - Empty CFG"+  | otherwise+  = (blockFreqs', edgeFreqs')+  where+    -- Calculate fixpoints+    (blockFreqs, edgeFreqs) = calcFreqs nodeProbs backEdges' bodies' revOrder'+    blockFreqs' = mapFromList $ map (first fromVertex) (assocs blockFreqs) :: LabelMap Double+    edgeFreqs' = fmap fromVertexMap $ fromVertexMap edgeFreqs++    fromVertexMap :: IM.IntMap x -> LabelMap x+    fromVertexMap m = mapFromList . map (first fromVertex) $ IM.toList m++    revOrder = revPostorderFrom localCfg root :: [BlockId]+    loopResults@(LoopInfo backedges _levels bodies) = loopInfo localCfg root++    revOrder' = map toVertex revOrder+    backEdges' = map (bimap toVertex toVertex) backedges+    bodies' = map calcBody bodies++    estimatedCfg = staticBranchPrediction root loopResults localCfg+    -- Normalize the weights to probabilities and apply heuristics+    nodeProbs = cfgEdgeProbabilities estimatedCfg toVertex++    -- By mapping vertices to numbers in reverse post order we can bring any subset into reverse post+    -- order simply by sorting.+    -- TODO: The sort is redundant if we can guarantee that setElems returns elements ascending+    calcBody (backedge, blocks) =+        (toVertex $ snd backedge, sort . map toVertex $ (setElems blocks))++    vertexMapping = mapFromList $ zip revOrder [0..] :: LabelMap Int+    blockMapping = listArray (0,mapSize vertexMapping - 1) revOrder :: Array Int BlockId+    -- Map from blockId to indicies starting at zero+    toVertex :: BlockId -> Int+    toVertex   blockId  = expectJust "mkGlobalWeights" $ mapLookup blockId vertexMapping+    -- Map from indicies starting at zero to blockIds+    fromVertex :: Int -> BlockId+    fromVertex vertex   = blockMapping ! vertex++{- Note [Static Branch Prediction]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The work here has been based on the paper+"Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus.++The primary differences are that if we branch on the result of a heap+check we do not apply any of the heuristics.+The reason is simple: They look like loops in the control flow graph+but are usually never entered, and if at most once.++Currently implemented is a heuristic to predict that we do not exit+loops (lehPredicts) and one to predict that backedges are more likely+than any other edge.++The back edge case is special as it superceeds any other heuristic if it+applies.++Do NOT rely solely on nofib results for benchmarking this. I recommend at least+comparing megaparsec and container benchmarks. Nofib does not seeem to have+many instances of "loopy" Cmm where these make a difference.++TODO:+* The paper containers more benchmarks which should be implemented.+* If we turn the likelyhood on if/else branches into a probability+  instead of true/false we could implement this as a Cmm pass.+  + The complete Cmm code still exists and can be accessed by the heuristics+  + There is no chance of register allocation/codegen inserting branches/blocks+  + making the TransitionSource info wrong.+  + potential to use this information in CmmPasses.+  - Requires refactoring of all the code relying on the binary nature of likelyhood.+  - Requires refactoring `loopInfo` to work on both, Cmm Graphs and the backend CFG.+-}++-- | Combination of target node id and information about the branch+--   we are looking at.+type TargetNodeInfo = (BlockId, EdgeInfo)+++-- | Update branch weights based on certain heuristics.+-- See Note [Static Branch Prediction]+-- TODO: This should be combined with optimizeCFG+{-# SCC staticBranchPrediction #-}+staticBranchPrediction :: BlockId -> LoopInfo -> CFG -> CFG+staticBranchPrediction _root (LoopInfo l_backEdges loopLevels l_loops) cfg =+    -- pprTrace "staticEstimatesOn" (ppr (cfg)) $+    foldl' update cfg nodes+  where+    nodes = getCfgNodes cfg+    backedges = S.fromList $ l_backEdges+    -- Loops keyed by their back edge+    loops = M.fromList $ l_loops :: M.Map Edge LabelSet+    loopHeads = S.fromList $ map snd $ M.keys loops++    update :: CFG -> BlockId -> CFG+    update cfg node+        -- No successors, nothing to do.+        | null successors = cfg++        -- Mix of backedges and others:+        -- Always predict the backedges.+        | not (null m) && length m < length successors+        -- Heap/Stack checks "loop", but only once.+        -- So we simply exclude any case involving them.+        , not $ any (isHeapOrStackCheck  . transitionSource . snd) successors+        = let   loopChance = repeat $! pred_LBH / (fromIntegral $ length m)+                exitChance = repeat $! (1 - pred_LBH) / fromIntegral (length not_m)+                updates = zip (map fst m) loopChance ++ zip (map fst not_m) exitChance+        in  -- pprTrace "mix" (ppr (node,successors)) $+            foldl' (\cfg (to,weight) -> setEdgeWeight cfg weight node to) cfg updates++        -- For (regular) non-binary branches we keep the weights from the STG -> Cmm translation.+        | length successors /= 2+        = cfg++        -- Only backedges - no need to adjust+        | length m > 0+        = cfg++        -- A regular binary branch, we can plug addition predictors in here.+        | [(s1,s1_info),(s2,s2_info)] <- successors+        , not $ any (isHeapOrStackCheck  . transitionSource . snd) successors+        = -- Normalize weights to total of 1+            let !w1 = max (edgeWeight s1_info) (0)+                !w2 = max (edgeWeight s2_info) (0)+                -- Of both weights are <= 0 we set both to 0.5+                normalizeWeight w = if w1 + w2 == 0 then 0.5 else w/(w1+w2)+                !cfg'  = setEdgeWeight cfg  (normalizeWeight w1) node s1+                !cfg'' = setEdgeWeight cfg' (normalizeWeight w2) node s2++                -- Figure out which heuristics apply to these successors+                heuristics = map ($ ((s1,s1_info),(s2,s2_info)))+                            [lehPredicts, phPredicts, ohPredicts, ghPredicts, lhhPredicts, chPredicts+                            , shPredicts, rhPredicts]+                -- Apply result of a heuristic. Argument is the likelyhood+                -- predicted for s1.+                applyHeuristic :: CFG -> Maybe Prob -> CFG+                applyHeuristic cfg Nothing = cfg+                applyHeuristic cfg (Just (s1_pred :: Double))+                  | s1_old == 0 || s2_old == 0 ||+                    isHeapOrStackCheck (transitionSource s1_info) ||+                    isHeapOrStackCheck (transitionSource s2_info)+                  = cfg+                  | otherwise =+                    let -- Predictions from heuristic+                        s1_prob = EdgeWeight s1_pred :: EdgeWeight+                        s2_prob = 1.0 - s1_prob+                        -- Update+                        d = (s1_old * s1_prob) + (s2_old * s2_prob) :: EdgeWeight+                        s1_prob' = s1_old * s1_prob / d+                        !s2_prob' = s2_old * s2_prob / d+                        !cfg_s1 = setEdgeWeight cfg    s1_prob' node s1+                    in  -- pprTrace "Applying heuristic!" (ppr (node,s1,s2) $$ ppr (s1_prob', s2_prob')) $+                        setEdgeWeight cfg_s1 s2_prob' node s2+                  where+                    -- Old weights+                    s1_old = getEdgeWeight cfg node s1+                    s2_old = getEdgeWeight cfg node s2++            in+            -- pprTraceIt "RegularCfgResult" $+            foldl' applyHeuristic cfg'' heuristics++        -- Branch on heap/stack check+        | otherwise = cfg++      where+        -- Chance that loops are taken.+        pred_LBH = 0.875+        -- successors+        successors = getSuccessorEdges cfg node+        -- backedges+        (m,not_m) = partition (\succ -> S.member (node, fst succ) backedges) successors++        -- Heuristics return nothing if they don't say anything about this branch+        -- or Just (prob_s1) where prob_s1 is the likelyhood for s1 to be the+        -- taken branch. s1 is the branch in the true case.++        -- Loop exit heuristic.+        -- We are unlikely to leave a loop unless it's to enter another one.+        pred_LEH = 0.75+        -- If and only if no successor is a loopheader,+        -- then we will likely not exit the current loop body.+        lehPredicts :: (TargetNodeInfo,TargetNodeInfo) -> Maybe Prob+        lehPredicts ((s1,_s1_info),(s2,_s2_info))+          | S.member s1 loopHeads || S.member s2 loopHeads+          = Nothing++          | otherwise+          = --pprTrace "lehPredict:" (ppr $ compare s1Level s2Level) $+            case compare s1Level s2Level of+                EQ -> Nothing+                LT -> Just (1-pred_LEH) --s1 exits to a shallower loop level (exits loop)+                GT -> Just (pred_LEH)   --s1 exits to a deeper loop level+            where+                s1Level = mapLookup s1 loopLevels+                s2Level = mapLookup s2 loopLevels++        -- Comparing to a constant is unlikely to be equal.+        ohPredicts (s1,_s2)+            | CmmSource { trans_cmmNode = src1 } <- getTransitionSource node (fst s1) cfg+            , CmmCondBranch cond ltrue _lfalse likely <- src1+            , likely == Nothing+            , CmmMachOp mop args <- cond+            , MO_Eq {} <- mop+            , not (null [x | x@CmmLit{} <- args])+            = if fst s1 == ltrue then Just 0.3 else Just 0.7++            | otherwise+            = Nothing++        -- TODO: These are all the other heuristics from the paper.+        -- Not all will apply, for now we just stub them out as Nothing.+        phPredicts = const Nothing+        ghPredicts = const Nothing+        lhhPredicts = const Nothing+        chPredicts = const Nothing+        shPredicts = const Nothing+        rhPredicts = const Nothing++-- We normalize all edge weights as probabilities between 0 and 1.+-- Ignoring rounding errors all outgoing edges sum up to 1.+cfgEdgeProbabilities :: CFG -> (BlockId -> Int) -> IM.IntMap (IM.IntMap Prob)+cfgEdgeProbabilities cfg toVertex+    = mapFoldlWithKey foldEdges IM.empty cfg+  where+    foldEdges = (\m from toMap -> IM.insert (toVertex from) (normalize toMap) m)++    normalize :: (LabelMap EdgeInfo) -> (IM.IntMap Prob)+    normalize weightMap+        | edgeCount <= 1 = mapFoldlWithKey (\m k _ -> IM.insert (toVertex k) 1.0 m) IM.empty weightMap+        | otherwise = mapFoldlWithKey (\m k _ -> IM.insert (toVertex k) (normalWeight k) m) IM.empty weightMap+      where+        edgeCount = mapSize weightMap+        -- Negative weights are generally allowed but are mapped to zero.+        -- We then check if there is at least one non-zero edge and if not+        -- assign uniform weights to all branches.+        minWeight = 0 :: Prob+        weightMap' = fmap (\w -> max (weightToDouble . edgeWeight $ w) minWeight) weightMap+        totalWeight = sum weightMap'++        normalWeight :: BlockId -> Prob+        normalWeight bid+         | totalWeight == 0+         = 1.0 / fromIntegral edgeCount+         | Just w <- mapLookup bid weightMap'+         = w/totalWeight+         | otherwise = panic "impossible"++-- This is the fixpoint algorithm from+--   "Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus+-- The adaption to Haskell is my own.+calcFreqs :: IM.IntMap (IM.IntMap Prob) -> [(Int,Int)] -> [(Int, [Int])] -> [Int]+          -> (Array Int Double, IM.IntMap (IM.IntMap Prob))+calcFreqs graph backEdges loops revPostOrder = runST $ do+    visitedNodes <- newArray (0,nodeCount-1) False :: ST s (STUArray s Int Bool)+    blockFreqs <- newArray (0,nodeCount-1) 0.0 :: ST s (STUArray s Int Double)+    edgeProbs <- newSTRef graph+    edgeBackProbs <- newSTRef graph++    -- let traceArray a = do+    --       vs <- forM [0..nodeCount-1] $ \i -> readArray a i >>= (\v -> return (i,v))+          -- trace ("array: " ++ show vs) $ return ()++    let  -- See #1600, we need to inline or unboxing makes perf worse.+        -- {-# INLINE getFreq #-}+        {-# INLINE visited #-}+        visited b = unsafeRead visitedNodes b+        getFreq b = unsafeRead blockFreqs b+        -- setFreq :: forall s. Int -> Double -> ST s ()+        setFreq b f = unsafeWrite blockFreqs b f+        -- setVisited :: forall s. Node -> ST s ()+        setVisited b = unsafeWrite visitedNodes b True+        -- Frequency/probability that edge is taken.+        getProb' arr b1 b2 = readSTRef arr >>=+            (\graph ->+                return .+                        fromMaybe (error "getFreq 1") .+                        IM.lookup b2 .+                        fromMaybe (error "getFreq 2") $+                        (IM.lookup b1 graph)+            )+        setProb' arr b1 b2 prob = do+          g <- readSTRef arr+          let !m = fromMaybe (error "Foo") $ IM.lookup b1 g+              !m' = IM.insert b2 prob m+          writeSTRef arr $! (IM.insert b1 m' g)++        getEdgeFreq b1 b2 = getProb' edgeProbs b1 b2+        setEdgeFreq b1 b2 = setProb' edgeProbs b1 b2+        getProb b1 b2 = fromMaybe (error "getProb") $ do+            m' <- IM.lookup b1 graph+            IM.lookup b2 m'++        getBackProb b1 b2 = getProb' edgeBackProbs b1 b2+        setBackProb b1 b2 = setProb' edgeBackProbs b1 b2+++    let -- calcOutFreqs :: Node -> ST s ()+        calcOutFreqs bhead block = do+          !f <- getFreq block+          forM (successors block) $ \bi -> do+            let !prob = getProb block bi+            let !succFreq = f * prob+            setEdgeFreq block bi succFreq+            -- traceM $ "SetOut: " ++ show (block, bi, f, prob, succFreq)+            when (bi == bhead) $ setBackProb block bi succFreq+++    let propFreq block head = do+            -- traceM ("prop:" ++ show (block,head))+            -- traceShowM block++            !v <- visited block+            if v then+                return () --Dont look at nodes twice+            else if block == head then+                setFreq block 1.0 -- Loop header frequency is always 1+            else do+                let preds = IS.elems $ predecessors block+                irreducible <- (fmap or) $ forM preds $ \bp -> do+                    !bp_visited <- visited bp+                    let bp_backedge = isBackEdge bp block+                    return (not bp_visited && not bp_backedge)++                if irreducible+                then return () -- Rare we don't care+                else do+                    setFreq block 0+                    !cycleProb <- sum <$> (forM preds $ \pred -> do+                        if isBackEdge pred block+                            then+                                getBackProb pred block+                            else do+                                !f <- getFreq block+                                !prob <- getEdgeFreq pred block+                                setFreq block $! f + prob+                                return 0)+                    -- traceM $ "cycleProb:" ++ show cycleProb+                    let limit = 1 - 1/512 -- Paper uses 1 - epsilon, but this works.+                                          -- determines how large likelyhoods in loops can grow.+                    !cycleProb <- return $ min cycleProb limit -- <- return $ if cycleProb > limit then limit else cycleProb+                    -- traceM $ "cycleProb:" ++ show cycleProb++                    !f <- getFreq block+                    setFreq block (f / (1.0 - cycleProb))++            setVisited block+            calcOutFreqs head block++    -- Loops, by nesting, inner to outer+    forM_ loops $ \(head, body) -> do+        forM_ [0 .. nodeCount - 1] (\i -> unsafeWrite visitedNodes i True) -- Mark all nodes as visited.+        forM_ body (\i -> unsafeWrite visitedNodes i False) -- Mark all blocks reachable from head as not visited+        forM_ body $ \block -> propFreq block head++    -- After dealing with all loops, deal with non-looping parts of the CFG+    forM_ [0 .. nodeCount - 1] (\i -> unsafeWrite visitedNodes i False) -- Everything in revPostOrder is reachable+    forM_ revPostOrder $ \block -> propFreq block (head revPostOrder)++    -- trace ("Final freqs:") $ return ()+    -- let freqString = pprFreqs freqs+    -- trace (unlines freqString) $ return ()+    -- trace (pprFre) $ return ()+    graph' <- readSTRef edgeProbs+    freqs' <- unsafeFreeze  blockFreqs++    return (freqs', graph')+  where+    -- How can these lookups fail? Consider the CFG [A -> B]+    predecessors :: Int -> IS.IntSet+    predecessors b = fromMaybe IS.empty $ IM.lookup b revGraph+    successors :: Int -> [Int]+    successors b = fromMaybe (lookupError "succ" b graph)$ IM.keys <$> IM.lookup b graph+    lookupError s b g = pprPanic ("Lookup error " ++ s) $+                            ( text "node" <+> ppr b $$+                                text "graph" <+>+                                vcat (map (\(k,m) -> ppr (k,m :: IM.IntMap Double)) $ IM.toList g)+                            )++    nodeCount = IM.foldl' (\count toMap -> IM.foldlWithKey' countTargets count toMap) (IM.size graph) graph+      where+        countTargets = (\count k _ -> countNode k + count )+        countNode n = if IM.member n graph then 0 else 1++    isBackEdge from to = S.member (from,to) backEdgeSet+    backEdgeSet = S.fromList backEdges++    revGraph :: IntMap IntSet+    revGraph = IM.foldlWithKey' (\m from toMap -> addEdges m from toMap) IM.empty graph+        where+            addEdges m0 from toMap = IM.foldlWithKey' (\m k _ -> addEdge m from k) m0 toMap+            addEdge m0 from to = IM.insertWith IS.union to (IS.singleton from) m0
compiler/nativeGen/CPrim.hs view
@@ -8,6 +8,7 @@     , pdepLabel     , pextLabel     , bSwapLabel+    , bRevLabel     , clzLabel     , ctzLabel     , word2FloatLabel@@ -53,6 +54,15 @@     pprWidth W32 = "32"     pprWidth W64 = "64"     pprWidth w   = pprPanic "bSwapLabel: Unsupported word width " (ppr w)++bRevLabel :: Width -> String+bRevLabel w = "hs_bitrev" ++ pprWidth w+  where+    pprWidth W8  = "8"+    pprWidth W16 = "16"+    pprWidth W32 = "32"+    pprWidth W64 = "64"+    pprWidth w   = pprPanic "bRevLabel: Unsupported word width " (ppr w)  clzLabel :: Width -> String clzLabel w = "hs_clz" ++ pprWidth w
compiler/nativeGen/Dwarf.hs view
@@ -12,7 +12,7 @@ import DynFlags import Module import Outputable-import Platform+import GHC.Platform import Unique import UniqSupply @@ -116,7 +116,7 @@           , pprHalf 3                          -- DWARF version           , sectionOffset (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel)                                                -- abbrevs offset-          , text "\t.byte " <> ppr (platformWordSize plat) -- word size+          , text "\t.byte " <> ppr (platformWordSizeInBytes plat) -- word size           ]  -- | Compilation unit footer, mainly establishing size of debug sections
compiler/nativeGen/Dwarf/Constants.hs view
@@ -7,7 +7,7 @@  import AsmUtils import FastString-import Platform+import GHC.Platform import Outputable  import Reg
compiler/nativeGen/Dwarf/Types.hs view
@@ -30,7 +30,7 @@ import Encoding import FastString import Outputable-import Platform+import GHC.Platform import Unique import Reg import SrcLoc@@ -38,6 +38,7 @@  import Dwarf.Constants +import qualified Data.ByteString as BS import qualified Control.Monad.Trans.State.Strict as S import Control.Monad (zipWithM, join) import Data.Bits@@ -45,7 +46,7 @@ import Data.Word import Data.Char -import CodeGen.Platform+import GHC.Platform.Regs  -- | Individual dwarf records. Each one will be encoded as an entry in -- the @.debug_info@ section.@@ -223,7 +224,7 @@ -- address table entry. pprDwarfARanges :: [DwarfARange] -> Unique -> SDoc pprDwarfARanges arngs unitU = sdocWithPlatform $ \plat ->-  let wordSize = platformWordSize plat+  let wordSize = platformWordSizeInBytes plat       paddingSize = 4 :: Int       -- header is 12 bytes long.       -- entry is 8 bytes (32-bit platform) or 16 bytes (64-bit platform).@@ -293,7 +294,7 @@         length      = ppr cieEndLabel <> char '-' <> ppr cieStartLabel         spReg       = dwarfGlobalRegNo plat Sp         retReg      = dwarfReturnRegNo plat-        wordSize    = platformWordSize plat+        wordSize    = platformWordSizeInBytes plat         pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc         pprInit (g, uw) = pprSetUnwind plat g (Nothing, uw) @@ -454,9 +455,9 @@ pprSetUnwind _    Sp (_, Just uw)   = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr False uw pprSetUnwind plat g  (_, Just (UwDeref (UwReg Sp o)))-  | o < 0 && ((-o) `mod` platformWordSize plat) == 0 -- expected case+  | o < 0 && ((-o) `mod` platformWordSizeInBytes plat) == 0 -- expected case   = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$-    pprLEBWord (fromIntegral ((-o) `div` platformWordSize plat))+    pprLEBWord (fromIntegral ((-o) `div` platformWordSizeInBytes plat))   | otherwise   = pprByte dW_CFA_offset_extended_sf $$     pprLEBRegNo plat g $$@@ -517,10 +518,9 @@ wordAlign = sdocWithPlatform $ \plat ->   text "\t.align " <> case platformOS plat of     OSDarwin -> case platformWordSize plat of-      8      -> text "3"-      4      -> text "2"-      _other -> error "wordAlign: Unsupported word size!"-    _other   -> ppr (platformWordSize plat)+      PW8 -> char '3'+      PW4 -> char '2'+    _other   -> ppr (platformWordSizeInBytes plat)  -- | Assembly for a single byte of constant DWARF data pprByte :: Word8 -> SDoc@@ -552,10 +552,8 @@ pprWord :: SDoc -> SDoc pprWord s = (<> s) . sdocWithPlatform $ \plat ->   case platformWordSize plat of-    4 -> text "\t.long "-    8 -> text "\t.quad "-    n -> panic $ "pprWord: Unsupported target platform word length " ++-                 show n ++ "!"+    PW4 -> text "\t.long "+    PW8 -> text "\t.quad "  -- | Prints a number in "little endian base 128" format. The idea is -- to optimize for small numbers by stopping once all further bytes@@ -584,7 +582,7 @@   = pprString' $ hcat $ map escapeChar $     if str `lengthIs` utf8EncodedLength str     then str-    else map (chr . fromIntegral) $ bytesFS $ mkFastString str+    else map (chr . fromIntegral) $ BS.unpack $ bytesFS $ mkFastString str  -- | Escape a single non-unicode character escapeChar :: Char -> SDoc
compiler/nativeGen/Format.hs view
@@ -47,7 +47,6 @@         | II64         | FF32         | FF64-        | FF80         deriving (Show, Eq)  @@ -70,7 +69,7 @@  = case width of         W32     -> FF32         W64     -> FF64-        W80     -> FF80+         other   -> pprPanic "Format.floatFormat" (ppr other)  @@ -80,7 +79,6 @@  = case format of         FF32    -> True         FF64    -> True-        FF80    -> True         _       -> False  @@ -101,7 +99,7 @@         II64            -> W64         FF32            -> W32         FF64            -> W64-        FF80            -> W80+  formatInBytes :: Format -> Int formatInBytes = widthInBytes . formatToWidth
compiler/nativeGen/Instruction.hs view
@@ -23,7 +23,7 @@ import Hoopl.Label import DynFlags import Cmm hiding (topInfoTable)-import Platform+import GHC.Platform  -- | Holds a list of source and destination registers used by a --      particular instruction.
− compiler/nativeGen/NCG.h 
@@ -1,11 +0,0 @@-/* -------------------------------------------------------------------------------   (c) The University of Glasgow, 1994-2004--   Native-code generator header file - just useful macros for now.--   -------------------------------------------------------------------------- */--#pragma once--#include "ghc_boot_platform.h"
compiler/nativeGen/NCGMonad.hs view
@@ -20,7 +20,7 @@         addNodeBetweenNat,         addImmediateSuccessorNat,         updateCfgNat,-        getUniqueNat, getCfgNat,+        getUniqueNat,         mapAccumLNat,         setDeltaNat,         getDeltaNat,@@ -41,7 +41,7 @@  where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -61,13 +61,12 @@ import DynFlags import Module -import Control.Monad    ( liftM, ap )+import Control.Monad    ( ap )  import Instruction 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],@@ -79,7 +78,6 @@     pprNatCmmDecl             :: NatCmmDecl statics instr -> SDoc,     maxSpillSlots             :: Int,     allocatableRegs           :: [RealReg],-    ncg_x86fp_kludge          :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],     ncgExpandTop              :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],     ncgAllocMoreStack         :: Int -> NatCmmDecl statics instr                               -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)]),@@ -117,6 +115,7 @@ type DwarfFiles = UniqFM (FastString, Int)  newtype NatM result = NatM (NatM_State -> (result, NatM_State))+    deriving (Functor)  unNat :: NatM a -> NatM_State -> (a, NatM_State) unNat (NatM a) = a@@ -142,9 +141,6 @@ initNat init_st m         = case unNat m init_st of { (r,st) -> (r,st) } -instance Functor NatM where-      fmap = liftM- instance Applicative NatM where       pure = returnNat       (<*>) = ap@@ -212,9 +208,6 @@         = 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@@ -238,7 +231,7 @@  -- | Place `succ` after `block` and change any edges --   block -> X to `succ` -> X-addImmediateSuccessorNat :: HasDebugCallStack => BlockId -> BlockId -> NatM ()+addImmediateSuccessorNat :: BlockId -> BlockId -> NatM () addImmediateSuccessorNat block succ         = updateCfgNat (addImmediateSuccessor block succ)
compiler/nativeGen/PIC.hs view
@@ -54,7 +54,7 @@  import qualified X86.Instr      as X86 -import Platform+import GHC.Platform import Instruction import Reg import NCGMonad@@ -563,23 +563,21 @@ -- For each processor architecture, there are two versions, one for PIC -- and one for non-PIC. ----- Whenever you change something in this assembler output, make sure--- the splitter in driver/split/ghc-split.pl recognizes the new output  pprImportedSymbol :: DynFlags -> Platform -> CLabel -> SDoc-pprImportedSymbol dflags platform@(Platform { platformArch = ArchX86, platformOS = OSDarwin }) importedLbl+pprImportedSymbol dflags (Platform { platformMini = PlatformMini { platformMini_arch = ArchX86, platformMini_os = OSDarwin } }) importedLbl         | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl         = case positionIndependent dflags of            False ->             vcat [                 text ".symbol_stub",-                text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"),-                    text "\t.indirect_symbol" <+> pprCLabel platform lbl,-                    text "\tjmp *L" <> pprCLabel platform lbl+                text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"),+                    text "\t.indirect_symbol" <+> pprCLabel dflags lbl,+                    text "\tjmp *L" <> pprCLabel dflags lbl                         <> text "$lazy_ptr",-                text "L" <> pprCLabel platform lbl+                text "L" <> pprCLabel dflags lbl                     <> text "$stub_binder:",-                    text "\tpushl $L" <> pprCLabel platform lbl+                    text "\tpushl $L" <> pprCLabel dflags lbl                         <> text "$lazy_ptr",                     text "\tjmp dyld_stub_binding_helper"             ]@@ -587,16 +585,16 @@             vcat [                 text ".section __TEXT,__picsymbolstub2,"                     <> text "symbol_stubs,pure_instructions,25",-                text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"),-                    text "\t.indirect_symbol" <+> pprCLabel platform lbl,+                text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"),+                    text "\t.indirect_symbol" <+> pprCLabel dflags lbl,                     text "\tcall ___i686.get_pc_thunk.ax",                 text "1:",-                    text "\tmovl L" <> pprCLabel platform lbl+                    text "\tmovl L" <> pprCLabel dflags lbl                         <> text "$lazy_ptr-1b(%eax),%edx",                     text "\tjmp *%edx",-                text "L" <> pprCLabel platform lbl+                text "L" <> pprCLabel dflags lbl                     <> text "$stub_binder:",-                    text "\tlea L" <> pprCLabel platform lbl+                    text "\tlea L" <> pprCLabel dflags lbl                         <> text "$lazy_ptr-1b(%eax),%eax",                     text "\tpushl %eax",                     text "\tjmp dyld_stub_binding_helper"@@ -604,23 +602,23 @@           $+$ vcat [        text ".section __DATA, __la_sym_ptr"                     <> (if positionIndependent dflags then int 2 else int 3)                     <> text ",lazy_symbol_pointers",-                text "L" <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr:"),-                    text "\t.indirect_symbol" <+> pprCLabel platform lbl,-                    text "\t.long L" <> pprCLabel platform lbl+                text "L" <> pprCLabel dflags lbl <> ptext (sLit "$lazy_ptr:"),+                    text "\t.indirect_symbol" <+> pprCLabel dflags lbl,+                    text "\t.long L" <> pprCLabel dflags lbl                     <> text "$stub_binder"]          | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl         = vcat [                 text ".non_lazy_symbol_pointer",-                char 'L' <> pprCLabel platform lbl <> text "$non_lazy_ptr:",-                text "\t.indirect_symbol" <+> pprCLabel platform lbl,+                char 'L' <> pprCLabel dflags lbl <> text "$non_lazy_ptr:",+                text "\t.indirect_symbol" <+> pprCLabel dflags lbl,                 text "\t.long\t0"]          | otherwise         = empty  -pprImportedSymbol _ (Platform { platformOS = OSDarwin }) _+pprImportedSymbol _ (Platform { platformMini = PlatformMini { platformMini_os = OSDarwin } }) _         = empty  -- XCOFF / AIX@@ -634,12 +632,12 @@ -- -- NB: No DSO-support yet -pprImportedSymbol _ platform@(Platform { platformOS = OSAIX }) importedLbl+pprImportedSymbol dflags (Platform { platformMini = PlatformMini { platformMini_os = OSAIX } }) importedLbl         = case dynamicLinkerLabelInfo importedLbl of             Just (SymbolPtr, lbl)               -> vcat [-                   text "LC.." <> pprCLabel platform lbl <> char ':',-                   text "\t.long" <+> pprCLabel platform lbl ]+                   text "LC.." <> pprCLabel dflags lbl <> char ':',+                   text "\t.long" <+> pprCLabel dflags lbl ]             _ -> empty  -- ELF / Linux@@ -671,15 +669,15 @@ -- the NCG will keep track of all DynamicLinkerLabels it uses -- and output each of them using pprImportedSymbol. -pprImportedSymbol _ platform@(Platform { platformArch = ArchPPC_64 _ })+pprImportedSymbol dflags platform@(Platform { platformMini = PlatformMini { platformMini_arch = ArchPPC_64 _ } })                   importedLbl         | osElfTarget (platformOS platform)         = case dynamicLinkerLabelInfo importedLbl of             Just (SymbolPtr, lbl)               -> vcat [                    text ".section \".toc\", \"aw\"",-                   text ".LC_" <> pprCLabel platform lbl <> char ':',-                   text "\t.quad" <+> pprCLabel platform lbl ]+                   text ".LC_" <> pprCLabel dflags lbl <> char ':',+                   text "\t.quad" <+> pprCLabel dflags lbl ]             _ -> empty  pprImportedSymbol dflags platform importedLbl@@ -693,8 +691,8 @@                   in vcat [                       text ".section \".got2\", \"aw\"",-                      text ".LC_" <> pprCLabel platform lbl <> char ':',-                      ptext symbolSize <+> pprCLabel platform lbl ]+                      text ".LC_" <> pprCLabel dflags lbl <> char ':',+                      ptext symbolSize <+> pprCLabel dflags lbl ]              -- PLT code stubs are generated automatically by the dynamic linker.             _ -> empty
compiler/nativeGen/PPC/CodeGen.hs view
@@ -20,14 +20,12 @@  where -#include "GhclibHsVersions.h"-#include "nativeGen/NCG.h"-#include "../includes/MachDeps.h"+#include "HsVersions.h"  -- NCG stuff: import GhcPrelude -import CodeGen.Platform+import GHC.Platform.Regs import PPC.Instr import PPC.Cond import PPC.Regs@@ -41,7 +39,7 @@ import RegClass import Reg import TargetReg-import Platform+import GHC.Platform  -- Our intermediate code: import BlockId@@ -180,10 +178,16 @@       return (b1 `appOL` b2)     CmmSwitch arg ids -> do dflags <- getDynFlags                             genSwitch dflags arg ids-    CmmCall { cml_target = arg } -> genJump arg+    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]+jumpRegs dflags gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]+    where platform = targetPlatform dflags  -------------------------------------------------------------------------------- -- | 'InstrBlock's are the insn sequences generated by the insn selectors.@@ -1043,19 +1047,19 @@   -genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock+genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock -genJump (CmmLit (CmmLabel lbl))-  = return (unitOL $ JMP lbl)+genJump (CmmLit (CmmLabel lbl)) regs+  = return (unitOL $ JMP lbl regs) -genJump tree+genJump tree gregs   = do         dflags <- getDynFlags-        genJump' tree (platformToGCP (targetPlatform dflags))+        genJump' tree (platformToGCP (targetPlatform dflags)) gregs -genJump' :: CmmExpr -> GenCCallPlatform -> NatM InstrBlock+genJump' :: CmmExpr -> GenCCallPlatform -> [Reg] -> NatM InstrBlock -genJump' tree (GCP64ELF 1)+genJump' tree (GCP64ELF 1) regs   = do         (target,code) <- getSomeReg tree         return (code@@ -1063,20 +1067,20 @@                `snocOL` LD II64 toc (AddrRegImm target (ImmInt 8))                `snocOL` MTCTR r11                `snocOL` LD II64 r11 (AddrRegImm target (ImmInt 16))-               `snocOL` BCTR [] Nothing)+               `snocOL` BCTR [] Nothing regs) -genJump' tree (GCP64ELF 2)+genJump' tree (GCP64ELF 2) regs   = do         (target,code) <- getSomeReg tree         return (code                `snocOL` MR r12 target                `snocOL` MTCTR r12-               `snocOL` BCTR [] Nothing)+               `snocOL` BCTR [] Nothing regs) -genJump' tree _+genJump' tree _ regs   = do         (target,code) <- getSomeReg tree-        return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing)+        return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing regs)  -- ----------------------------------------------------------------------------- --  Unconditional branches@@ -1590,7 +1594,7 @@     -> [CmmActual]        -- arguments (of mixed type)     -> NatM InstrBlock -{- +{-     PowerPC Linux uses the System V Release 4 Calling Convention     for PowerPC. It is described in the     "System V Application Binary Interface PowerPC Processor Supplement".@@ -1903,7 +1907,7 @@                           FF32 -> (1, 1, 4, fprs)                           FF64 -> (2, 1, 8, fprs)                           II64 -> panic "genCCall' passArguments II64"-                          FF80 -> panic "genCCall' passArguments FF80"+                       GCP32ELF ->                           case cmmTypeFormat rep of                           II8  -> (1, 0, 4, gprs)@@ -1913,7 +1917,6 @@                           FF32 -> (0, 1, 4, fprs)                           FF64 -> (0, 1, 8, fprs)                           II64 -> panic "genCCall' passArguments II64"-                          FF80 -> panic "genCCall' passArguments FF80"                       GCP64ELF _ ->                           case cmmTypeFormat rep of                           II8  -> (1, 0, 8, gprs)@@ -1925,7 +1928,6 @@                           -- the FPRs.                           FF32 -> (1, 1, 8, fprs)                           FF64 -> (1, 1, 8, fprs)-                          FF80 -> panic "genCCall' passArguments FF80"          moveResult reduceToFF32 =             case dest_regs of@@ -1953,7 +1955,9 @@             where                 (functionName, reduce) = case mop of                     MO_F32_Exp   -> (fsLit "exp", True)+                    MO_F32_ExpM1 -> (fsLit "expm1", True)                     MO_F32_Log   -> (fsLit "log", True)+                    MO_F32_Log1P -> (fsLit "log1p", True)                     MO_F32_Sqrt  -> (fsLit "sqrt", True)                     MO_F32_Fabs  -> unsupported @@ -1975,7 +1979,9 @@                     MO_F32_Atanh -> (fsLit "atanh", True)                      MO_F64_Exp   -> (fsLit "exp", False)+                    MO_F64_ExpM1 -> (fsLit "expm1", False)                     MO_F64_Log   -> (fsLit "log", False)+                    MO_F64_Log1P -> (fsLit "log1p", False)                     MO_F64_Sqrt  -> (fsLit "sqrt", False)                     MO_F64_Fabs  -> unsupported @@ -2004,6 +2010,7 @@                     MO_Memcmp _  -> (fsLit "memcmp", False)                      MO_BSwap w   -> (fsLit $ bSwapLabel w, False)+                    MO_BRev w    -> (fsLit $ bRevLabel w, False)                     MO_PopCnt w  -> (fsLit $ popCntLabel w, False)                     MO_Pdep w    -> (fsLit $ pdepLabel w, False)                     MO_Pext w    -> (fsLit $ pextLabel w, False)@@ -2048,7 +2055,7 @@                             SL fmt tmp reg (RIImm (ImmInt sha)),                             LD fmt tmp (AddrRegReg tableReg tmp),                             MTCTR tmp,-                            BCTR ids (Just lbl)+                            BCTR ids (Just lbl) []                     ]         return code @@ -2066,7 +2073,7 @@                             LD fmt tmp (AddrRegReg tableReg tmp),                             ADD tmp tmp (RIReg tableReg),                             MTCTR tmp,-                            BCTR ids (Just lbl)+                            BCTR ids (Just lbl) []                     ]         return code   | otherwise@@ -2081,14 +2088,14 @@                             ADDIS tmp tmp (HA (ImmCLbl lbl)),                             LD fmt tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),                             MTCTR tmp,-                            BCTR ids (Just lbl)+                            BCTR ids (Just lbl) []                     ]         return code   where (offset, ids) = switchTargetsToTable targets  generateJumpTableForInstr :: DynFlags -> Instr                           -> Maybe (NatCmmDecl CmmStatics Instr)-generateJumpTableForInstr dflags (BCTR ids (Just lbl)) =+generateJumpTableForInstr dflags (BCTR ids (Just lbl) _) =     let jumpTable             | (positionIndependent dflags)               || (not $ target32Bit $ targetPlatform dflags)
compiler/nativeGen/PPC/Instr.hs view
@@ -8,8 +8,7 @@ -- ----------------------------------------------------------------------------- -#include "GhclibHsVersions.h"-#include "nativeGen/NCG.h"+#include "HsVersions.h"  module PPC.Instr (     archWordFormat,@@ -33,7 +32,7 @@ import RegClass import Reg -import CodeGen.Platform+import GHC.Platform.Regs import BlockId import Hoopl.Collections import Hoopl.Label@@ -43,7 +42,7 @@ import FastString import CLabel import Outputable-import Platform+import GHC.Platform import UniqFM (listToUFM, lookupUFM) import UniqSupply @@ -98,7 +97,7 @@     , STU fmt r0 (AddrRegReg sp tmp)     ]   where-    fmt = intFormat $ widthFromBytes (platformWordSize platform)+    fmt = intFormat $ widthFromBytes (platformWordSizeInBytes platform)     zero = ImmInt 0     tmp = tmpReg platform     immAmount = ImmInt amount@@ -151,12 +150,12 @@             -- "labeled-goto" we use JMP, and for "computed-goto" we             -- use MTCTR followed by BCTR. See 'PPC.CodeGen.genJump'.             = case insn of-                JMP _           -> dealloc ++ (insn : r)-                BCTR [] Nothing -> dealloc ++ (insn : r)-                BCTR ids label  -> BCTR (map (fmap retarget) ids) label : r-                BCCFAR cond b p -> BCCFAR cond (retarget b) p : r-                BCC    cond b p -> BCC    cond (retarget b) p : r-                _               -> insn : r+                JMP _ _           -> dealloc ++ (insn : r)+                BCTR [] Nothing _ -> dealloc ++ (insn : r)+                BCTR ids label rs -> BCTR (map (fmap retarget) ids) label rs : r+                BCCFAR cond b p   -> BCCFAR cond (retarget b) p : r+                BCC    cond b p   -> BCC    cond (retarget b) p : r+                _                 -> insn : r             -- BL and BCTRL are call-like instructions rather than             -- jumps, and are used only for C calls. @@ -223,10 +222,13 @@                                     --    Just True:  branch likely taken                                     --    Just False: branch likely not taken                                     --    Nothing:    no hint-    | JMP     CLabel                -- same as branch,+    | JMP     CLabel [Reg]          -- same as branch,                                     -- but with CLabel instead of block ID+                                    -- and live global registers     | MTCTR   Reg-    | BCTR    [Maybe BlockId] (Maybe CLabel) -- with list of local destinations, and jump table location if necessary+    | BCTR    [Maybe BlockId] (Maybe CLabel) [Reg]+                                    -- with list of local destinations, and+                                    -- jump table location if necessary     | BL      CLabel [Reg]          -- with list of argument regs     | BCTRL   [Reg] @@ -324,8 +326,9 @@     CMPL    _ reg ri         -> usage (reg : regRI ri,[])     BCC     _ _ _            -> noUsage     BCCFAR  _ _ _            -> noUsage+    JMP     _ regs           -> usage (regs, [])     MTCTR   reg              -> usage ([reg],[])-    BCTR    _ _              -> noUsage+    BCTR    _ _ regs         -> usage (regs, [])     BL      _ params         -> usage (params, callClobberedRegs platform)     BCTRL   params           -> usage (params, callClobberedRegs platform) @@ -416,8 +419,9 @@     CMPL    fmt reg ri      -> CMPL fmt (env reg) (fixRI ri)     BCC     cond lbl p      -> BCC cond lbl p     BCCFAR  cond lbl p      -> BCCFAR cond lbl p+    JMP     l regs          -> JMP l regs -- global regs will not be remapped     MTCTR   reg             -> MTCTR (env reg)-    BCTR    targets lbl     -> BCTR targets lbl+    BCTR    targets lbl rs  -> BCTR targets lbl rs     BL      imm argRegs     -> BL imm argRegs    -- argument regs     BCTRL   argRegs         -> BCTRL argRegs     -- cannot be remapped     ADD     reg1 reg2 ri    -> ADD (env reg1) (env reg2) (fixRI ri)@@ -506,10 +510,10 @@ ppc_jumpDestsOfInstr :: Instr -> [BlockId] ppc_jumpDestsOfInstr insn   = case insn of-        BCC _ id _      -> [id]-        BCCFAR _ id _   -> [id]-        BCTR targets _  -> [id | Just id <- targets]-        _               -> []+        BCC _ id _       -> [id]+        BCCFAR _ id _    -> [id]+        BCTR targets _ _ -> [id | Just id <- targets]+        _                -> []   -- | Change the destination of this jump instruction.@@ -520,7 +524,7 @@   = case insn of         BCC cc id p     -> BCC cc (patchF id) p         BCCFAR cc id p  -> BCCFAR cc (patchF id) p-        BCTR ids lbl    -> BCTR (map (fmap patchF) ids) lbl+        BCTR ids lbl rs -> BCTR (map (fmap patchF) ids) lbl rs         _               -> insn
compiler/nativeGen/PPC/Ppr.hs view
@@ -27,9 +27,10 @@  import BlockId import CLabel+import PprCmmExpr () -- For Outputable instances  import Unique                ( pprUniqueAlways, getUnique )-import Platform+import GHC.Platform import FastString import Outputable import DynFlags@@ -49,17 +50,14 @@   case topInfoTable proc of     Nothing ->        sdocWithPlatform $ \platform ->-       case blocks of-         []     -> -- special case for split markers:-           pprLabel lbl-         blocks -> -- special case for code without info table:-           pprSectionAlign (Section Text lbl) $$-           (case platformArch platform of-              ArchPPC_64 ELF_V1 -> pprFunctionDescriptor lbl-              ArchPPC_64 ELF_V2 -> pprFunctionPrologue lbl-              _ -> pprLabel lbl) $$ -- blocks guaranteed not null,+         -- special case for code without info table:+         pprSectionAlign (Section Text lbl) $$+         (case platformArch platform of+            ArchPPC_64 ELF_V1 -> pprFunctionDescriptor lbl+            ArchPPC_64 ELF_V2 -> pprFunctionPrologue lbl+            _ -> pprLabel lbl) $$ -- blocks guaranteed not null,                                      -- so label needed-           vcat (map (pprBasicBlock top_info) blocks)+         vcat (map (pprBasicBlock top_info) blocks)      Just (Statics info_lbl _) ->       sdocWithPlatform $ \platform ->@@ -122,11 +120,20 @@   pprDatas :: CmmStatics -> SDoc+-- See note [emit-time elimination of static indirections] in CLabel.+pprDatas (Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])+  | lbl == mkIndStaticInfoLabel+  , let labelInd (CmmLabelOff l _) = Just l+        labelInd (CmmLabel l) = Just l+        labelInd _ = Nothing+  , Just ind' <- labelInd ind+  , alias `mayRedirectTo` ind'+  = pprGloblDecl alias+    $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats)  pprData :: CmmStatic -> SDoc-pprData (CmmString str)-  = text "\t.string" <+> doubleQuotes (pprASCII str)+pprData (CmmString str)          = pprBytes str pprData (CmmUninitialised bytes) = text ".space " <> int bytes pprData (CmmStaticLit lit)       = pprDataItem lit @@ -165,7 +172,7 @@       RegVirtual (VirtualRegHi u)  -> text "%vHi_"  <> pprUniqueAlways u       RegVirtual (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u       RegVirtual (VirtualRegD  u)  -> text "%vD_"   <> pprUniqueAlways u-      RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> pprUniqueAlways u+   where     ppr_reg_no :: Int -> SDoc     ppr_reg_no i@@ -183,8 +190,7 @@                 II32 -> sLit "w"                 II64 -> sLit "d"                 FF32 -> sLit "fs"-                FF64 -> sLit "fd"-                _    -> panic "PPC.Ppr.pprFormat: no match")+                FF64 -> sLit "fd")   pprCond :: Cond -> SDoc@@ -369,7 +375,6 @@             II64 -> sLit "d"             FF32 -> sLit "fs"             FF64 -> sLit "fd"-            _         -> panic "PPC.Ppr.pprInstr: no match"             ),         case addr of AddrRegImm _ _ -> empty                      AddrRegReg _ _ -> char 'x',@@ -409,7 +414,6 @@             II64 -> sLit "d"             FF32 -> sLit "fs"             FF64 -> sLit "fd"-            _         -> panic "PPC.Ppr.pprInstr: no match"             ),         case addr of AddrRegImm _ _ -> empty                      AddrRegReg _ _ -> char 'x',@@ -552,7 +556,7 @@             Just True  -> char '-'             Just False -> char '+' -pprInstr (JMP lbl)+pprInstr (JMP lbl _)   -- We never jump to ForeignLabels; if we ever do, c.f. handling for "BL"   | isForeignLabel lbl = panic "PPC.Ppr.pprInstr: JMP to ForeignLabel"   | otherwise =@@ -569,7 +573,7 @@         char '\t',         pprReg reg     ]-pprInstr (BCTR _ _) = hcat [+pprInstr (BCTR _ _ _) = hcat [         char '\t',         text "bctr"     ]@@ -758,12 +762,12 @@     -- Handle the case where we are asked to shift a 32 bit register by     -- less than zero or more than 31 bits. We convert this into a clear     -- of the destination register.-    -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/5900+    -- Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/5900     pprInstr (XOR reg1 reg2 (RIReg reg2))  pprInstr (SL II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0  || i > 31 =     -- As above for SR, but for left shifts.-    -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/10870+    -- Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/10870     pprInstr (XOR reg1 reg2 (RIReg reg2))  pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt i))) | i > 31 =
compiler/nativeGen/PPC/RegInfo.hs view
@@ -17,8 +17,7 @@  where -#include "nativeGen/NCG.h"-#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude
compiler/nativeGen/PPC/Regs.hs view
@@ -37,9 +37,9 @@         fits16Bits,         makeImmediate,         fReg,-        r0, sp, toc, r3, r4, r11, r12, r27, r28, r30,+        r0, sp, toc, r3, r4, r11, r12, r30,         tmpReg,-        f1, f20, f21,+        f1,          allocatableRegs @@ -47,8 +47,7 @@  where -#include "nativeGen/NCG.h"-#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -60,10 +59,10 @@ import CLabel           ( CLabel ) import Unique -import CodeGen.Platform+import GHC.Platform.Regs import DynFlags import Outputable-import Platform+import GHC.Platform  import Data.Word        ( Word8, Word16, Word32, Word64 ) import Data.Int         ( Int8, Int16, Int32, Int64 )@@ -131,9 +130,9 @@         RcInteger       -> text "blue"         RcFloat         -> text "red"         RcDouble        -> text "green"-        RcDoubleSSE     -> text "yellow"  + -- immediates ------------------------------------------------------------------ data Imm         = ImmInt        Int@@ -306,7 +305,7 @@ fReg :: Int -> RegNo fReg x = (32 + x) -r0, sp, toc, r3, r4, r11, r12, r27, r28, r30, f1, f20, f21 :: Reg+r0, sp, toc, r3, r4, r11, r12, r30, f1 :: Reg r0      = regSingle 0 sp      = regSingle 1 toc     = regSingle 2@@ -314,12 +313,8 @@ r4      = regSingle 4 r11     = regSingle 11 r12     = regSingle 12-r27     = regSingle 27-r28     = regSingle 28 r30     = regSingle 30 f1      = regSingle $ fReg 1-f20     = regSingle $ fReg 20-f21     = regSingle $ fReg 21  -- allocatableRegs is allMachRegNos with the fixed-use regs removed. -- i.e., these are the regs for which we are prepared to allow the@@ -335,4 +330,4 @@        case platformArch platform of        ArchPPC      -> regSingle 13        ArchPPC_64 _ -> regSingle 30-       _            -> panic "PPC.Regs.tmpReg: unknowm arch"+       _            -> panic "PPC.Regs.tmpReg: unknown arch"
compiler/nativeGen/PprBase.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE MagicHash #-}+ ----------------------------------------------------------------------------- -- -- Pretty-printing assembly language@@ -12,6 +14,7 @@         floatToBytes,         doubleToBytes,         pprASCII,+        pprBytes,         pprSectionHeader ) @@ -25,7 +28,8 @@ import DynFlags import FastString import Outputable-import Platform+import GHC.Platform+import FileCleanup  import qualified Data.Array.Unsafe as U ( castSTUArray ) import Data.Array.ST@@ -33,7 +37,12 @@ import Control.Monad.ST  import Data.Word-import Data.Char+import Data.Bits+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import GHC.Exts+import GHC.Word+import System.IO.Unsafe   @@ -90,29 +99,83 @@ -- Print as a string and escape non-printable characters. -- This is similar to charToC in Utils. -pprASCII :: [Word8] -> SDoc+pprASCII :: ByteString -> SDoc pprASCII str   -- Transform this given literal bytestring to escaped string and construct   -- the literal SDoc directly.-  -- See Trac #14741+  -- See #14741   -- and Note [Pretty print ASCII when AsmCodeGen]-  = text $ foldr (\w s -> (do1 . fromIntegral) w ++ s) "" str+  = text $ BS.foldr (\w s -> do1 w ++ s) "" str     where-       do1 :: Int -> String-       do1 w | '\t' <- chr w = "\\t"-             | '\n' <- chr w = "\\n"-             | '"'  <- chr w = "\\\""-             | '\\' <- chr w = "\\\\"-             | isPrint (chr w) = [chr w]+       do1 :: Word8 -> String+       do1 w | 0x09 == w = "\\t"+             | 0x0A == w = "\\n"+             | 0x22 == w = "\\\""+             | 0x5C == w = "\\\\"+               -- ASCII printable characters range+             | w >= 0x20 && w <= 0x7E = [chr' w]              | otherwise = '\\' : octal w -       octal :: Int -> String-       octal w = [ chr (ord '0' + (w `div` 64) `mod` 8)-                 , chr (ord '0' + (w `div` 8) `mod` 8)-                 , chr (ord '0' + w `mod` 8)+       -- we know that the Chars we create are in the ASCII range+       -- so we bypass the check in "chr"+       chr' :: Word8 -> Char+       chr' (W8# w#) = C# (chr# (word2Int# w#))++       octal :: Word8 -> String+       octal w = [ chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07)+                 , chr' (ord0 + (w `unsafeShiftR` 3) .&. 0x07)+                 , chr' (ord0 + w .&. 0x07)                  ]+       ord0 = 0x30 -- = ord '0' +-- | Pretty print binary data.+--+-- Use either the ".string" directive or a ".incbin" directive.+-- See Note [Embedding large binary blobs]+--+-- A NULL byte is added after the binary data.+--+pprBytes :: ByteString -> SDoc+pprBytes bs = sdocWithDynFlags $ \dflags ->+  if binBlobThreshold dflags == 0+     || fromIntegral (BS.length bs) <= binBlobThreshold dflags+    then text "\t.string " <> doubleQuotes (pprASCII bs)+    else unsafePerformIO $ do+      bFile <- newTempName dflags TFL_CurrentModule ".dat"+      BS.writeFile bFile bs+      return $ text "\t.incbin "+         <> pprFilePathString bFile -- proper escape (see #16389)+         <> text "\n\t.byte 0"+ {-+Note [Embedding large binary blobs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++To embed a blob of binary data (e.g. an UTF-8 encoded string) into the generated+code object, we have several options:++   1. Generate a ".byte" directive for each byte. This is what was done in the past+      (see Note [Pretty print ASCII when AsmCodeGen]).++   2. Generate a single ".string"/".asciz" directive for the whole sequence of+      bytes. Bytes in the ASCII printable range are rendered as characters and+      other values are escaped (e.g., "\t", "\077", etc.).++   3. Create a temporary file into which we dump the binary data and generate a+      single ".incbin" directive. The assembler will include the binary file for+      us in the generated output object.++Now the code generator uses either (2) or (3), depending on the binary blob+size.  Using (3) for small blobs adds too much overhead (see benchmark results+in #16190), so we only do it when the size is above a threshold (500K at the+time of writing).++The threshold is configurable via the `-fbinary-blob-threshold` flag.++-}+++{- Note [Pretty print ASCII when AsmCodeGen] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Previously, when generating assembly code, we created SDoc with@@ -126,7 +189,7 @@ Now we escape the given bytestring to string directly and construct SDoc only once. This improvement could dramatically decrease the memory allocation from 4.7GB to 1.3GB when embedding a 3MB literal-string in source code. See Trac #14741 for profiling results.+string in source code. See #14741 for profiling results. -}  -- ----------------------------------------------------------------------------
compiler/nativeGen/Reg.hs view
@@ -31,7 +31,7 @@ import Outputable import Unique import RegClass-import Data.List+import Data.List (intersect)  -- | An identifier for a primitive real machine register. type RegNo@@ -56,7 +56,7 @@         | VirtualRegHi {-# UNPACK #-} !Unique  -- High part of 2-word register         | VirtualRegF  {-# UNPACK #-} !Unique         | VirtualRegD  {-# UNPACK #-} !Unique-        | VirtualRegSSE {-# UNPACK #-} !Unique+         deriving (Eq, Show)  -- This is laborious, but necessary. We can't derive Ord because@@ -69,17 +69,16 @@   compare (VirtualRegHi a) (VirtualRegHi b) = nonDetCmpUnique a b   compare (VirtualRegF a) (VirtualRegF b) = nonDetCmpUnique a b   compare (VirtualRegD a) (VirtualRegD b) = nonDetCmpUnique a b-  compare (VirtualRegSSE a) (VirtualRegSSE b) = nonDetCmpUnique a b+   compare VirtualRegI{} _ = LT   compare _ VirtualRegI{} = GT   compare VirtualRegHi{} _ = LT   compare _ VirtualRegHi{} = GT   compare VirtualRegF{} _ = LT   compare _ VirtualRegF{} = GT-  compare VirtualRegD{} _ = LT-  compare _ VirtualRegD{} = GT  + instance Uniquable VirtualReg where         getUnique reg          = case reg of@@ -87,18 +86,20 @@                 VirtualRegHi u  -> u                 VirtualRegF u   -> u                 VirtualRegD u   -> u-                VirtualRegSSE u -> u  instance Outputable VirtualReg where         ppr reg          = case reg of                 VirtualRegI  u  -> text "%vI_"   <> pprUniqueAlways u                 VirtualRegHi u  -> text "%vHi_"  <> pprUniqueAlways u-                VirtualRegF  u  -> text "%vF_"   <> pprUniqueAlways u-                VirtualRegD  u  -> text "%vD_"   <> pprUniqueAlways u-                VirtualRegSSE u -> text "%vSSE_" <> pprUniqueAlways u+                -- this code is kinda wrong on x86+                -- because float and double occupy the same register set+                -- namely SSE2 register xmm0 .. xmm15+                VirtualRegF  u  -> text "%vFloat_"   <> pprUniqueAlways u+                VirtualRegD  u  -> text "%vDouble_"   <> pprUniqueAlways u  + renameVirtualReg :: Unique -> VirtualReg -> VirtualReg renameVirtualReg u r  = case r of@@ -106,7 +107,6 @@         VirtualRegHi _  -> VirtualRegHi u         VirtualRegF _   -> VirtualRegF  u         VirtualRegD _   -> VirtualRegD  u-        VirtualRegSSE _ -> VirtualRegSSE u   classOfVirtualReg :: VirtualReg -> RegClass@@ -116,7 +116,7 @@         VirtualRegHi{}  -> RcInteger         VirtualRegF{}   -> RcFloat         VirtualRegD{}   -> RcDouble-        VirtualRegSSE{} -> RcDoubleSSE+   -- Determine the upper-half vreg for a 64-bit quantity on a 32-bit platform
compiler/nativeGen/RegAlloc/Graph/Main.hs view
@@ -21,7 +21,7 @@ import Bag import DynFlags import Outputable-import Platform+import GHC.Platform import UniqFM import UniqSet import UniqSupply@@ -89,7 +89,8 @@ --   and try to colour it again. After `maxSpinCount` iterations we give up. -- regAlloc_spin-        :: (Instruction instr,+        :: forall instr statics.+           (Instruction instr,             Outputable instr,             Outputable statics)         => DynFlags@@ -180,7 +181,7 @@                 | otherwise                 = reg -        let code_coalesced+        let (code_coalesced :: [LiveCmmDecl statics instr])                 = map (patchEraseLive patchF) code          -- Check whether we've found a coloring.@@ -309,7 +310,7 @@         -- Add the reg-reg conflicts to the graph.         let conflictBag         = unionManyBags conflictList         let graph_conflict-                = foldrBag graphAddConflictSet Color.initGraph conflictBag+                = foldr graphAddConflictSet Color.initGraph conflictBag          -- Add the coalescences edges to the graph.         let moveBag@@ -317,7 +318,7 @@                             (unionManyBags moveList)          let graph_coalesce-                = foldrBag graphAddCoalesce graph_conflict moveBag+                = foldr graphAddCoalesce graph_conflict moveBag          return  graph_coalesce
compiler/nativeGen/RegAlloc/Graph/Spill.hs view
@@ -23,7 +23,7 @@ import UniqSet import UniqSupply import Outputable-import Platform+import GHC.Platform  import Data.List import Data.Maybe@@ -105,12 +105,8 @@          -> return cmm          CmmProc info label live sccs-         |  LiveInfo static firstId mLiveVRegsOnEntry liveSlotsOnEntry <- info+         |  LiveInfo static firstId liveVRegsOnEntry liveSlotsOnEntry <- info          -> do-                -- We should only passed Cmms with the liveness maps filled in,-                -- but we'll create empty ones if they're not there just in case.-                let liveVRegsOnEntry    = fromMaybe mapEmpty mLiveVRegsOnEntry-                 -- The liveVRegsOnEntry contains the set of vregs that are live                 -- on entry to each basic block. If we spill one of those vregs                 -- we remove it from that set and add the corresponding slot@@ -124,7 +120,7 @@                  let info'                         = LiveInfo static firstId-                                (Just liveVRegsOnEntry)+                                liveVRegsOnEntry                                 liveSlotsOnEntry'                  -- Apply the spiller to all the basic blocks in the CmmProc.
compiler/nativeGen/RegAlloc/Graph/SpillClean.hs view
@@ -41,7 +41,7 @@ import Unique import State import Outputable-import Platform+import GHC.Platform import Hoopl.Collections  import Data.List
compiler/nativeGen/RegAlloc/Graph/SpillCost.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables, GADTs, BangPatterns #-} module RegAlloc.Graph.SpillCost (         SpillCostRecord,         plusSpillCostRecord,@@ -23,12 +23,13 @@ import GraphBase  import Hoopl.Collections (mapLookup)+import Hoopl.Label import Cmm import UniqFM import UniqSet import Digraph          (flattenSCCs) import Outputable-import Platform+import GHC.Platform import State import CFG @@ -49,9 +50,6 @@ type SpillCostInfo         = UniqFM SpillCostRecord --- | Block membership in a loop-type LoopMember = Bool- type SpillCostState = State (UniqFM SpillCostRecord) ()  -- | An empty map of spill costs.@@ -88,45 +86,49 @@  where         countCmm CmmData{}              = return ()         countCmm (CmmProc info _ _ sccs)-                = mapM_ (countBlock info)+                = mapM_ (countBlock info freqMap)                 $ flattenSCCs sccs+            where+                LiveInfo _ entries _ _ = info+                freqMap = (fst . mkGlobalWeights (head entries)) <$> cfg          -- Lookup the regs that are live on entry to this block in         --      the info table from the CmmProc.-        countBlock info (BasicBlock blockId instrs)-                | LiveInfo _ _ (Just blockLive) _ <- info+        countBlock info freqMap (BasicBlock blockId instrs)+                | LiveInfo _ _ blockLive _ <- info                 , Just rsLiveEntry  <- mapLookup blockId blockLive                 , rsLiveEntry_virt  <- takeVirtuals rsLiveEntry-                = countLIs (loopMember blockId) rsLiveEntry_virt instrs+                = countLIs (ceiling $ blockFreq freqMap blockId) rsLiveEntry_virt instrs                  | otherwise                 = error "RegAlloc.SpillCost.slurpSpillCostInfo: bad block" -        countLIs :: LoopMember -> UniqSet VirtualReg -> [LiveInstr instr] -> SpillCostState++        countLIs :: Int -> UniqSet VirtualReg -> [LiveInstr instr] -> SpillCostState         countLIs _      _      []                 = return ()          -- Skip over comment and delta pseudo instrs.-        countLIs inLoop rsLive (LiveInstr instr Nothing : lis)+        countLIs scale rsLive (LiveInstr instr Nothing : lis)                 | isMetaInstr instr-                = countLIs inLoop rsLive lis+                = countLIs scale rsLive lis                  | otherwise                 = pprPanic "RegSpillCost.slurpSpillCostInfo"                 $ text "no liveness information on instruction " <> ppr instr -        countLIs inLoop rsLiveEntry (LiveInstr instr (Just live) : lis)+        countLIs scale rsLiveEntry (LiveInstr instr (Just live) : lis)          = do                 -- Increment the lifetime counts for regs live on entry to this instr.-                mapM_ (incLifetime (loopCount inLoop)) $ nonDetEltsUniqSet rsLiveEntry+                mapM_ incLifetime $ nonDetEltsUniqSet rsLiveEntry                     -- This is non-deterministic but we do not                     -- currently support deterministic code-generation.                     -- See Note [Unique Determinism and code generation]                  -- Increment counts for what regs were read/written from.                 let (RU read written)   = regUsageOfInstr platform instr-                mapM_ (incUses (loopCount inLoop)) $ catMaybes $ map takeVirtualReg $ nub read-                mapM_ (incDefs (loopCount inLoop)) $ catMaybes $ map takeVirtualReg $ nub written+                mapM_ (incUses scale) $ catMaybes $ map takeVirtualReg $ nub read+                mapM_ (incDefs scale) $ catMaybes $ map takeVirtualReg $ nub written                  -- Compute liveness for entry to next instruction.                 let liveDieRead_virt    = takeVirtuals (liveDieRead  live)@@ -140,21 +142,18 @@                         = (rsLiveAcross `unionUniqSets` liveBorn_virt)                                         `minusUniqSet`  liveDieWrite_virt -                countLIs inLoop rsLiveNext lis+                countLIs scale rsLiveNext lis -        loopCount inLoop-          | inLoop = 10-          | otherwise = 1         incDefs     count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, count, 0, 0)         incUses     count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, count, 0)-        incLifetime count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, count)+        incLifetime       reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, 1) -        loopBlocks = CFG.loopMembers <$> cfg-        loopMember bid-          | Just isMember <- join (mapLookup bid <$> loopBlocks)-          = isMember+        blockFreq :: Maybe (LabelMap Double) -> Label -> Double+        blockFreq freqs bid+          | Just freq <- join (mapLookup bid <$> freqs)+          = max 1.0 (10000 * freq)           | otherwise-          = False+          = 1.0 -- Only if no cfg given  -- | Take all the virtual registers from this set. takeVirtuals :: UniqSet Reg -> UniqSet VirtualReg@@ -215,31 +214,39 @@ --  Without live range splitting, its's better to spill from the outside --  in so set the cost of very long live ranges to zero ---{--spillCost_chaitin-        :: SpillCostInfo-        -> Graph Reg RegClass Reg-        -> Reg-        -> Float -spillCost_chaitin info graph reg-        -- Spilling a live range that only lives for 1 instruction-        -- isn't going to help us at all - and we definitely want to avoid-        -- trying to re-spill previously inserted spill code.-        | lifetime <= 1         = 1/0+-- spillCost_chaitin+--         :: SpillCostInfo+--         -> Graph VirtualReg RegClass RealReg+--         -> VirtualReg+--         -> Float -        -- It's unlikely that we'll find a reg for a live range this long-        -- better to spill it straight up and not risk trying to keep it around-        -- and have to go through the build/color cycle again.-        | lifetime > allocatableRegsInClass (regClass reg) * 10-        = 0+-- spillCost_chaitin info graph reg+--         -- Spilling a live range that only lives for 1 instruction+--         -- isn't going to help us at all - and we definitely want to avoid+--         -- trying to re-spill previously inserted spill code.+--         | lifetime <= 1         = 1/0 -        -- Otherwise revert to chaitin's regular cost function.-        | otherwise     = fromIntegral (uses + defs)-                        / fromIntegral (nodeDegree graph reg)-        where (_, defs, uses, lifetime)-                = fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg--}+--         -- It's unlikely that we'll find a reg for a live range this long+--         -- better to spill it straight up and not risk trying to keep it around+--         -- and have to go through the build/color cycle again.++--         -- To facility this we scale down the spill cost of long ranges.+--         -- This makes sure long ranges are still spilled first.+--         -- But this way spill cost remains relevant for long live+--         -- ranges.+--         | lifetime >= 128+--         = (spillCost / conflicts) / 10.0+++--         -- Otherwise revert to chaitin's regular cost function.+--         | otherwise = (spillCost / conflicts)+--         where+--             !spillCost = fromIntegral (uses + defs) :: Float+--             conflicts = fromIntegral (nodeDegree classOfVirtualReg graph reg)+--             (_, defs, uses, lifetime)+--                 = fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg+  -- Just spill the longest live range. spillCost_length
compiler/nativeGen/RegAlloc/Graph/Stats.hs view
@@ -14,8 +14,6 @@         countSRMs, addSRM ) where -#include "nativeGen/NCG.h"- import GhcPrelude  import qualified GraphColor as Color@@ -28,7 +26,6 @@ import Reg import TargetReg -import PprCmm() import Outputable import UniqFM import UniqSet
compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs view
@@ -6,7 +6,7 @@  where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -16,7 +16,7 @@ import GraphBase  import UniqSet-import Platform+import GHC.Platform import Panic  -- trivColorable ---------------------------------------------------------------@@ -119,6 +119,7 @@                             ArchAlpha     -> panic "trivColorable ArchAlpha"                             ArchMipseb    -> panic "trivColorable ArchMipseb"                             ArchMipsel    -> panic "trivColorable ArchMipsel"+                            ArchS390X     -> panic "trivColorable ArchS390X"                             ArchJavaScript-> panic "trivColorable ArchJavaScript"                             ArchUnknown   -> panic "trivColorable ArchUnknown")         , count2        <- accSqueeze 0 cALLOCATABLE_REGS_INTEGER@@ -134,6 +135,10 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions         | let cALLOCATABLE_REGS_FLOAT                   =        (case platformArch platform of+                    -- On x86_64 and x86, Float and RcDouble+                    -- use the same registers,+                    -- so we only use RcDouble to represent the+                    -- register allocation problem on those types.                             ArchX86       -> 0                             ArchX86_64    -> 0                             ArchPPC       -> 0@@ -145,6 +150,7 @@                             ArchAlpha     -> panic "trivColorable ArchAlpha"                             ArchMipseb    -> panic "trivColorable ArchMipseb"                             ArchMipsel    -> panic "trivColorable ArchMipsel"+                            ArchS390X     -> panic "trivColorable ArchS390X"                             ArchJavaScript-> panic "trivColorable ArchJavaScript"                             ArchUnknown   -> panic "trivColorable ArchUnknown")         , count2        <- accSqueeze 0 cALLOCATABLE_REGS_FLOAT@@ -160,8 +166,14 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions         | let cALLOCATABLE_REGS_DOUBLE                   =        (case platformArch platform of-                            ArchX86       -> 6-                            ArchX86_64    -> 0+                            ArchX86       -> 8+                            -- in x86 32bit mode sse2 there are only+                            -- 8 XMM registers xmm0 ... xmm7+                            ArchX86_64    -> 10+                            -- in x86_64 there are 16 XMM registers+                            -- xmm0 .. xmm15, here 10 is a+                            -- "dont need to solve conflicts" count that+                            -- was chosen at some point in the past.                             ArchPPC       -> 26                             ArchSPARC     -> 11                             ArchSPARC64   -> panic "trivColorable ArchSPARC64"@@ -171,6 +183,7 @@                             ArchAlpha     -> panic "trivColorable ArchAlpha"                             ArchMipseb    -> panic "trivColorable ArchMipseb"                             ArchMipsel    -> panic "trivColorable ArchMipsel"+                            ArchS390X     -> panic "trivColorable ArchS390X"                             ArchJavaScript-> panic "trivColorable ArchJavaScript"                             ArchUnknown   -> panic "trivColorable ArchUnknown")         , count2        <- accSqueeze 0 cALLOCATABLE_REGS_DOUBLE@@ -183,31 +196,7 @@          = count3 < cALLOCATABLE_REGS_DOUBLE -trivColorable platform virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts exclusions-        | let cALLOCATABLE_REGS_SSE-                  =        (case platformArch platform of-                            ArchX86       -> 8-                            ArchX86_64    -> 10-                            ArchPPC       -> 0-                            ArchSPARC     -> 0-                            ArchSPARC64   -> panic "trivColorable ArchSPARC64"-                            ArchPPC_64 _  -> 0-                            ArchARM _ _ _ -> panic "trivColorable ArchARM"-                            ArchARM64     -> panic "trivColorable ArchARM64"-                            ArchAlpha     -> panic "trivColorable ArchAlpha"-                            ArchMipseb    -> panic "trivColorable ArchMipseb"-                            ArchMipsel    -> panic "trivColorable ArchMipsel"-                            ArchJavaScript-> panic "trivColorable ArchJavaScript"-                            ArchUnknown   -> panic "trivColorable ArchUnknown")-        , count2        <- accSqueeze 0 cALLOCATABLE_REGS_SSE-                                (virtualRegSqueeze RcDoubleSSE)-                                conflicts -        , count3        <- accSqueeze  count2    cALLOCATABLE_REGS_SSE-                                (realRegSqueeze   RcDoubleSSE)-                                exclusions--        = count3 < cALLOCATABLE_REGS_SSE   -- Specification Code ----------------------------------------------------------
compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs view
@@ -5,7 +5,7 @@     maxSpillSlots ) -#include "GhclibHsVersions.h"+#include "HsVersions.h"  where @@ -16,7 +16,7 @@  import DynFlags import Panic-import Platform+import GHC.Platform  -- ----------------------------------------------------------------------------- -- The free register set@@ -75,6 +75,7 @@                 ArchX86       -> X86.Instr.maxSpillSlots dflags                 ArchX86_64    -> X86.Instr.maxSpillSlots dflags                 ArchPPC       -> PPC.Instr.maxSpillSlots dflags+                ArchS390X     -> panic "maxSpillSlots ArchS390X"                 ArchSPARC     -> SPARC.Instr.maxSpillSlots dflags                 ArchSPARC64   -> panic "maxSpillSlots ArchSPARC64"                 ArchARM _ _ _ -> panic "maxSpillSlots ArchARM"
compiler/nativeGen/RegAlloc/Linear/Main.hs view
@@ -99,7 +99,7 @@         module  RegAlloc.Linear.Stats   ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"   import GhcPrelude@@ -130,7 +130,7 @@ import UniqFM import UniqSupply import Outputable-import Platform+import GHC.Platform  import Data.Maybe import Data.List@@ -162,7 +162,7 @@                  , Nothing )  regAlloc dflags (CmmProc static lbl live sccs)-        | LiveInfo info entry_ids@(first_id:_) (Just block_live) _ <- static+        | LiveInfo info entry_ids@(first_id:_) block_live _ <- static         = do                 -- do register allocation on each component.                 (final_blocks, stats, stack_use)@@ -211,6 +211,7 @@  = case platformArch platform of       ArchX86        -> go $ (frInitFreeRegs platform :: X86.FreeRegs)       ArchX86_64     -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs)+      ArchS390X      -> panic "linearRegAlloc ArchS390X"       ArchSPARC      -> go $ (frInitFreeRegs platform :: SPARC.FreeRegs)       ArchSPARC64    -> panic "linearRegAlloc ArchSPARC64"       ArchPPC        -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)
compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs view
@@ -9,7 +9,7 @@ import Reg  import Outputable-import Platform+import GHC.Platform  import Data.Word import Data.Bits
compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs view
@@ -9,9 +9,9 @@ import RegClass import Reg -import CodeGen.Platform+import GHC.Platform.Regs import Outputable-import Platform+import GHC.Platform  import Data.Word import Data.Bits
compiler/nativeGen/RegAlloc/Linear/State.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, PatternSynonyms #-}+{-# LANGUAGE CPP, PatternSynonyms, DeriveFunctor #-}  #if !defined(GHC_LOADED_INTO_GHCI) {-# LANGUAGE UnboxedTuples #-}@@ -50,7 +50,7 @@ import Unique import UniqSupply -import Control.Monad (liftM, ap)+import Control.Monad (ap)  -- Avoids using unboxed tuples when loading into GHCi #if !defined(GHC_LOADED_INTO_GHCI)@@ -63,15 +63,14 @@ #else  data RA_Result freeRegs a = RA_Result {-# UNPACK #-} !(RA_State freeRegs) !a+  deriving (Functor)  #endif  -- | The register allocator monad type. newtype RegM freeRegs a         = RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a }--instance Functor (RegM freeRegs) where-      fmap = liftM+        deriving (Functor)  instance Applicative (RegM freeRegs) where       pure a  =  RegM $ \s -> RA_Result s a
compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs view
@@ -9,7 +9,7 @@ import RegClass import Reg import Panic-import Platform+import GHC.Platform  import Data.Word import Data.Bits
compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs view
@@ -9,7 +9,7 @@ import RegClass import Reg import Panic-import Platform+import GHC.Platform  import Data.Word import Data.Bits
compiler/nativeGen/RegAlloc/Liveness.hs view
@@ -33,7 +33,7 @@         patchRegsLiveInstr,         reverseBlocksInTops,         regLiveness,-        natCmmTopToLive+        cmmTopLiveness   ) where import GhcPrelude @@ -45,13 +45,12 @@ import Hoopl.Collections import Hoopl.Label import Cmm hiding (RegSet, emptyRegSet)-import PprCmm()  import Digraph import DynFlags import MonadUtils import Outputable-import Platform+import GHC.Platform import UniqSet import UniqFM import UniqSupply@@ -178,7 +177,7 @@                 (LabelMap CmmStatics)     -- cmm info table static stuff                 [BlockId]                 -- entry points (first one is the                                           -- entry point for the proc).-                (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block+                (BlockMap RegSet)         -- argument locals live on entry to this block                 (BlockMap IntSet)         -- stack slots live on entry to this block  @@ -319,7 +318,7 @@                 = foldl'  (slurpBlock info) rs bs          slurpBlock info rs (BasicBlock blockId instrs)-                | LiveInfo _ _ (Just blockLive) _ <- info+                | LiveInfo _ _ blockLive _        <- info                 , Just rsLiveEntry                <- mapLookup blockId blockLive                 , (conflicts, moves)              <- slurpLIs rsLiveEntry rs instrs                 = (consBag rsLiveEntry conflicts, moves)@@ -504,10 +503,6 @@            in   CmmProc info label live                           (ListGraph $ map (stripLiveBlock dflags) $ first' : rest') -        -- procs used for stg_split_markers don't contain any blocks, and have no first_id.-        stripCmm (CmmProc (LiveInfo info [] _ _) label live [])-         =      CmmProc info label live (ListGraph [])-         -- If the proc has blocks but we don't know what the first one was, then we're dead.         stripCmm proc                  = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc)@@ -577,18 +572,15 @@         patchCmm cmm@CmmData{}  = cmm          patchCmm (CmmProc info label live sccs)-         | LiveInfo static id (Just blockMap) mLiveSlots <- info+         | LiveInfo static id blockMap mLiveSlots <- info          = let                 patchRegSet set = mkUniqSet $ map patchF $ nonDetEltsUFM set                   -- See Note [Unique Determinism and code generation]                 blockMap'       = mapMap (patchRegSet . getUniqSet) blockMap -                info'           = LiveInfo static id (Just blockMap') mLiveSlots+                info'           = LiveInfo static id blockMap' mLiveSlots            in   CmmProc info' label live $ map patchSCC sccs -         | otherwise-         = panic "RegAlloc.Liveness.patchEraseLive: no blockMap"-         patchSCC (AcyclicSCC b)  = AcyclicSCC (patchBlock b)         patchSCC (CyclicSCC  bs) = CyclicSCC  (map patchBlock bs) @@ -644,8 +636,16 @@   ----------------------------------------------------------------------------------- | Convert a NatCmmDecl to a LiveCmmDecl, with empty liveness information+-- | Convert a NatCmmDecl to a LiveCmmDecl, with liveness information +cmmTopLiveness+        :: (Outputable instr, Instruction instr)+        => Maybe CFG -> Platform+        -> NatCmmDecl statics instr+        -> UniqSM (LiveCmmDecl statics instr)+cmmTopLiveness cfg platform cmm+        = regLiveness platform $ natCmmTopToLive cfg cmm+ natCmmTopToLive         :: (Instruction instr, Outputable instr)         => Maybe CFG -> NatCmmDecl statics instr@@ -655,10 +655,10 @@         = CmmData i d  natCmmTopToLive _ (CmmProc info lbl live (ListGraph []))-        = CmmProc (LiveInfo info [] Nothing mapEmpty) lbl live []+        = CmmProc (LiveInfo info [] mapEmpty mapEmpty) lbl live []  natCmmTopToLive mCfg proc@(CmmProc info lbl live (ListGraph blocks@(first : _)))-        = CmmProc (LiveInfo info' (first_id : entry_ids) Nothing mapEmpty)+        = CmmProc (LiveInfo info' (first_id : entry_ids) mapEmpty mapEmpty)                 lbl live sccsLive    where         first_id        = blockId first@@ -706,7 +706,7 @@         reachable             | Just cfg <- mcfg             -- Our CFG only contains reachable nodes by construction at this point.-            = getCfgNodes cfg+            = setFromList $ getCfgNodes cfg             | otherwise             = setFromList $ [ node_key node | node <- reachablesG g1 roots ] @@ -731,6 +731,7 @@ -------------------------------------------------------------------------------- -- Annotate code with register liveness information --+ regLiveness         :: (Outputable instr, Instruction instr)         => Platform@@ -743,14 +744,14 @@ regLiveness _ (CmmProc info lbl live [])         | LiveInfo static mFirst _ _    <- info         = return $ CmmProc-                        (LiveInfo static mFirst (Just mapEmpty) mapEmpty)+                        (LiveInfo static mFirst mapEmpty mapEmpty)                         lbl live []  regLiveness platform (CmmProc info lbl live sccs)         | LiveInfo static mFirst _ liveSlotsOnEntry     <- info         = let   (ann_sccs, block_live)  = computeLiveness platform sccs -          in    return $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry)+          in    return $ CmmProc (LiveInfo static mFirst block_live liveSlotsOnEntry)                            lbl live ann_sccs
compiler/nativeGen/RegClass.hs view
@@ -18,7 +18,6 @@         = RcInteger         | RcFloat         | RcDouble-        | RcDoubleSSE -- x86 only: the SSE regs are a separate class         deriving Eq  @@ -26,10 +25,8 @@     getUnique RcInteger = mkRegClassUnique 0     getUnique RcFloat   = mkRegClassUnique 1     getUnique RcDouble  = mkRegClassUnique 2-    getUnique RcDoubleSSE = mkRegClassUnique 3  instance Outputable RegClass where     ppr RcInteger       = Outputable.text "I"     ppr RcFloat         = Outputable.text "F"     ppr RcDouble        = Outputable.text "D"-    ppr RcDoubleSSE     = Outputable.text "S"
compiler/nativeGen/SPARC/CodeGen.hs view
@@ -17,9 +17,7 @@  where -#include "GhclibHsVersions.h"-#include "nativeGen/NCG.h"-#include "../includes/MachDeps.h"+#include "HsVersions.h"  -- NCG stuff: import GhcPrelude@@ -31,7 +29,6 @@ import SPARC.CodeGen.Gen64 import SPARC.CodeGen.Gen32 import SPARC.CodeGen.Base-import SPARC.Ppr        () import SPARC.Instr import SPARC.Imm import SPARC.AddrMode@@ -59,7 +56,7 @@ import FastString import OrdList import Outputable-import Platform+import GHC.Platform  import Control.Monad    ( mapAndUnzipM ) @@ -618,7 +615,9 @@ outOfLineMachOp_table mop  = case mop of         MO_F32_Exp    -> fsLit "expf"+        MO_F32_ExpM1  -> fsLit "expm1f"         MO_F32_Log    -> fsLit "logf"+        MO_F32_Log1P  -> fsLit "log1pf"         MO_F32_Sqrt   -> fsLit "sqrtf"         MO_F32_Fabs   -> unsupported         MO_F32_Pwr    -> fsLit "powf"@@ -640,7 +639,9 @@         MO_F32_Atanh  -> fsLit "atanhf"          MO_F64_Exp    -> fsLit "exp"+        MO_F64_ExpM1  -> fsLit "expm1"         MO_F64_Log    -> fsLit "log"+        MO_F64_Log1P  -> fsLit "log1p"         MO_F64_Sqrt   -> fsLit "sqrt"         MO_F64_Fabs   -> unsupported         MO_F64_Pwr    -> fsLit "pow"@@ -669,6 +670,7 @@         MO_Memcmp _  -> fsLit "memcmp"          MO_BSwap w   -> fsLit $ bSwapLabel w+        MO_BRev w    -> fsLit $ bRevLabel w         MO_PopCnt w  -> fsLit $ popCntLabel w         MO_Pdep w    -> fsLit $ pdepLabel w         MO_Pext w    -> fsLit $ pextLabel w
compiler/nativeGen/SPARC/CodeGen/Base.hs view
@@ -22,11 +22,11 @@ import Format import Reg -import CodeGen.Platform+import GHC.Platform.Regs import DynFlags import Cmm-import PprCmmExpr ()-import Platform+import PprCmmExpr () -- For Outputable instances+import GHC.Platform  import Outputable import OrdList
compiler/nativeGen/SPARC/CodeGen/Expand.hs view
@@ -11,7 +11,6 @@ import SPARC.Imm import SPARC.AddrMode import SPARC.Regs-import SPARC.Ppr        () import Instruction import Reg import Format
compiler/nativeGen/SPARC/CodeGen/Gen64.hs view
@@ -16,7 +16,7 @@ import SPARC.AddrMode import SPARC.Imm import SPARC.Instr-import SPARC.Ppr()+-- import SPARC.Ppr() import NCGMonad import Instruction import Format
compiler/nativeGen/SPARC/CodeGen/Sanity.hs view
@@ -9,7 +9,7 @@ import GhcPrelude  import SPARC.Instr-import SPARC.Ppr        ()+import SPARC.Ppr        () -- For Outputable instances import Instruction  import Cmm
compiler/nativeGen/SPARC/Instr.hs view
@@ -7,8 +7,7 @@ -- (c) The University of Glasgow 1993-2004 -- ------------------------------------------------------------------------------#include "GhclibHsVersions.h"-#include "nativeGen/NCG.h"+#include "HsVersions.h"  module SPARC.Instr (         RI(..),@@ -40,13 +39,13 @@ import Format  import CLabel-import CodeGen.Platform+import GHC.Platform.Regs import BlockId import DynFlags import Cmm import FastString import Outputable-import Platform+import GHC.Platform   -- | Register or immediate@@ -384,7 +383,6 @@                         RcInteger -> II32                         RcFloat   -> FF32                         RcDouble  -> FF64-                        _         -> panic "sparc_mkSpillInstr"      in ST fmt reg (fpRel (negate off_w)) @@ -405,7 +403,6 @@                         RcInteger -> II32                         RcFloat   -> FF32                         RcDouble  -> FF64-                        _         -> panic "sparc_mkLoadInstr"          in LD fmt (fpRel (- off_w)) reg @@ -454,7 +451,6 @@                 RcInteger -> ADD  False False src (RIReg g0) dst                 RcDouble  -> FMOV FF64 src dst                 RcFloat   -> FMOV FF32 src dst-                _         -> panic "sparc_mkRegRegMoveInstr"          | otherwise         = panic "SPARC.Instr.mkRegRegMoveInstr: classes of src and dest not the same"
compiler/nativeGen/SPARC/Ppr.hs view
@@ -22,8 +22,7 @@  where -#include "GhclibHsVersions.h"-#include "nativeGen/NCG.h"+#include "HsVersions.h"  import GhcPrelude @@ -39,7 +38,7 @@ import PprBase  import Cmm hiding (topInfoTable)-import PprCmm()+import PprCmm() -- For Outputable instances import BlockId import CLabel import Hoopl.Label@@ -47,9 +46,8 @@  import Unique           ( pprUniqueAlways ) import Outputable-import Platform+import GHC.Platform import FastString-import Data.Word  -- ----------------------------------------------------------------------------- -- Printing this stuff out@@ -61,13 +59,10 @@ pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =   case topInfoTable proc of     Nothing ->-       case blocks of-         []     -> -- special case for split markers:-           pprLabel lbl-         blocks -> -- special case for code without info table:-           pprSectionAlign (Section Text lbl) $$-           pprLabel lbl $$ -- blocks guaranteed not null, so label needed-           vcat (map (pprBasicBlock top_info) blocks)+        -- special case for code without info table:+        pprSectionAlign (Section Text lbl) $$+        pprLabel lbl $$ -- blocks guaranteed not null, so label needed+        vcat (map (pprBasicBlock top_info) blocks)      Just (Statics info_lbl _) ->       sdocWithPlatform $ \platform ->@@ -106,14 +101,20 @@   pprDatas :: CmmStatics -> SDoc+-- See note [emit-time elimination of static indirections] in CLabel.+pprDatas (Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])+  | lbl == mkIndStaticInfoLabel+  , let labelInd (CmmLabelOff l _) = Just l+        labelInd (CmmLabel l) = Just l+        labelInd _ = Nothing+  , Just ind' <- labelInd ind+  , alias `mayRedirectTo` ind'+  = pprGloblDecl alias+    $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats)  pprData :: CmmStatic -> SDoc-pprData (CmmString str)-  = vcat (map do1 str) $$ do1 0-    where-       do1 :: Word8 -> SDoc-       do1 w = text "\t.byte\t" <> int (fromIntegral w)+pprData (CmmString str)          = pprBytes str pprData (CmmUninitialised bytes) = text ".skip " <> int bytes pprData (CmmStaticLit lit)       = pprDataItem lit @@ -151,8 +152,8 @@                 VirtualRegHi  u -> text "%vHi_"  <> pprUniqueAlways u                 VirtualRegF   u -> text "%vF_"   <> pprUniqueAlways u                 VirtualRegD   u -> text "%vD_"   <> pprUniqueAlways u-                VirtualRegSSE u -> text "%vSSE_" <> pprUniqueAlways u +         RegReal rr          -> case rr of                 RealRegSingle r1@@ -219,8 +220,7 @@         II32    -> sLit ""         II64    -> sLit "d"         FF32    -> sLit ""-        FF64    -> sLit "d"-        _       -> panic "SPARC.Ppr.pprFormat: no match")+        FF64    -> sLit "d")   -- | Pretty print a format for an instruction suffix.@@ -234,10 +234,10 @@         II32  -> sLit ""         II64  -> sLit "x"         FF32  -> sLit ""-        FF64  -> sLit "d"-        _       -> panic "SPARC.Ppr.pprFormat: no match")+        FF64  -> sLit "d")  + -- | Pretty print a condition code. pprCond :: Cond -> SDoc pprCond c@@ -643,4 +643,3 @@  pp_comma_a :: SDoc pp_comma_a        = text ",a"-
compiler/nativeGen/SPARC/Regs.hs view
@@ -34,7 +34,7 @@  import GhcPrelude -import CodeGen.Platform.SPARC+import GHC.Platform.SPARC import Reg import RegClass import Format@@ -104,7 +104,6 @@                 VirtualRegD{}           -> 1                 _other                  -> 0 -        _other -> 0  {-# INLINE realRegSqueeze #-} realRegSqueeze :: RegClass -> RealReg -> Int@@ -135,7 +134,6 @@                  RealRegPair{}           -> 1 -        _other -> 0  -- | All the allocatable registers in the machine, --      including register pairs.
compiler/nativeGen/TargetReg.hs view
@@ -19,7 +19,7 @@  where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -29,7 +29,7 @@  import Outputable import Unique-import Platform+import GHC.Platform  import qualified X86.Regs       as X86 import qualified X86.RegInfo    as X86@@ -44,6 +44,7 @@       ArchX86       -> X86.virtualRegSqueeze       ArchX86_64    -> X86.virtualRegSqueeze       ArchPPC       -> PPC.virtualRegSqueeze+      ArchS390X     -> panic "targetVirtualRegSqueeze ArchS390X"       ArchSPARC     -> SPARC.virtualRegSqueeze       ArchSPARC64   -> panic "targetVirtualRegSqueeze ArchSPARC64"       ArchPPC_64 _  -> PPC.virtualRegSqueeze@@ -62,6 +63,7 @@       ArchX86       -> X86.realRegSqueeze       ArchX86_64    -> X86.realRegSqueeze       ArchPPC       -> PPC.realRegSqueeze+      ArchS390X     -> panic "targetRealRegSqueeze ArchS390X"       ArchSPARC     -> SPARC.realRegSqueeze       ArchSPARC64   -> panic "targetRealRegSqueeze ArchSPARC64"       ArchPPC_64 _  -> PPC.realRegSqueeze@@ -79,6 +81,7 @@       ArchX86       -> X86.classOfRealReg platform       ArchX86_64    -> X86.classOfRealReg platform       ArchPPC       -> PPC.classOfRealReg+      ArchS390X     -> panic "targetClassOfRealReg ArchS390X"       ArchSPARC     -> SPARC.classOfRealReg       ArchSPARC64   -> panic "targetClassOfRealReg ArchSPARC64"       ArchPPC_64 _  -> PPC.classOfRealReg@@ -96,6 +99,7 @@       ArchX86       -> X86.mkVirtualReg       ArchX86_64    -> X86.mkVirtualReg       ArchPPC       -> PPC.mkVirtualReg+      ArchS390X     -> panic "targetMkVirtualReg ArchS390X"       ArchSPARC     -> SPARC.mkVirtualReg       ArchSPARC64   -> panic "targetMkVirtualReg ArchSPARC64"       ArchPPC_64 _  -> PPC.mkVirtualReg@@ -113,6 +117,7 @@       ArchX86       -> X86.regDotColor platform       ArchX86_64    -> X86.regDotColor platform       ArchPPC       -> PPC.regDotColor+      ArchS390X     -> panic "targetRegDotColor ArchS390X"       ArchSPARC     -> SPARC.regDotColor       ArchSPARC64   -> panic "targetRegDotColor ArchSPARC64"       ArchPPC_64 _  -> PPC.regDotColor
compiler/nativeGen/X86/CodeGen.hs view
@@ -1,9 +1,13 @@ {-# LANGUAGE CPP, GADTs, NondecreasingIndentation #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE BangPatterns #-} +#if __GLASGOW_HASKELL__ <= 808+-- GHC 8.10 deprecates this flag, but GHC 8.8 needs it -- The default iteration limit is a bit too low for the definitions -- in this module. {-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}+#endif  ----------------------------------------------------------------------------- --@@ -27,9 +31,7 @@  where -#include "GhclibHsVersions.h"-#include "nativeGen/NCG.h"-#include "../includes/MachDeps.h"+#include "HsVersions.h"  -- NCG stuff: import GhcPrelude@@ -40,10 +42,7 @@ import X86.Ppr (  ) import X86.RegInfo ---TODO: Remove - Just for development/debugging-import X86.Ppr()--import CodeGen.Platform+import GHC.Platform.Regs import CPrim import Debug            ( DebugBlock(..), UnwindPoint(..), UnwindTable                         , UnwindExpr(UwReg), toUnwindExpr )@@ -56,13 +55,12 @@ import CFG import Format import Reg-import Platform+import GHC.Platform  -- Our intermediate code: import BasicTypes import BlockId import Module           ( primUnitId )-import PprCmm           () import CmmUtils import CmmSwitch import Cmm@@ -100,17 +98,25 @@ sse2Enabled :: NatM Bool sse2Enabled = do   dflags <- getDynFlags-  return (isSse2Enabled dflags)+  case platformArch (targetPlatform dflags) of+  -- We Assume  SSE1 and SSE2 operations are available on both+  -- x86 and x86_64. Historically we didn't default to SSE2 and+  -- SSE1 on x86, which results in defacto nondeterminism for how+  -- rounding behaves in the associated x87 floating point instructions+  -- because variations in the spill/fpu stack placement of arguments for+  -- operations would change the precision and final result of what+  -- would otherwise be the same expressions with respect to single or+  -- double precision IEEE floating point computations.+    ArchX86_64 -> return True+    ArchX86    -> return True+    _          -> panic "trying to generate x86/x86_64 on the wrong platform" + sse4_2Enabled :: NatM Bool sse4_2Enabled = do   dflags <- getDynFlags   return (isSse4_2Enabled dflags) -if_sse2 :: NatM a -> NatM a -> NatM a-if_sse2 sse2 x87 = do-  b <- sse2Enabled-  if b then sse2 else x87  cmmTopCodeGen         :: RawCmmDecl@@ -130,7 +136,7 @@       Nothing -> return tops  cmmTopCodeGen (CmmData sec dat) = do-  return [CmmData sec (1, dat)]  -- no translation, we just use CmmStatic+  return [CmmData sec (mkAlignment 1, dat)]  -- no translation, we just use CmmStatic  {- Note [Verifying basic blocks]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -201,7 +207,7 @@             return $ unitOL $ LOCATION fileId line col name     _ -> return nilOL   (mid_instrs,mid_bid) <- stmtsToInstrs id stmts-  (tail_instrs,_) <- stmtToInstrs mid_bid tail+  (!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@@ -306,7 +312,7 @@     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'+      let !newBid = fromMaybe bid bid'       go newBid stmts (instrs `appOL` instrs')  -- | `bid` refers to the current block and is used to update the CFG@@ -414,15 +420,14 @@   -- | Grab the Reg for a CmmReg-getRegisterReg :: Platform -> Bool -> CmmReg -> Reg+getRegisterReg :: Platform  -> CmmReg -> Reg -getRegisterReg _ use_sse2 (CmmLocal (LocalReg u pk))-  = let fmt = cmmTypeFormat pk in-    if isFloatFormat fmt && not use_sse2-       then RegVirtual (mkVirtualReg u FF80)-       else RegVirtual (mkVirtualReg u fmt)+getRegisterReg _   (CmmLocal (LocalReg u pk))+  = -- by Assuming SSE2, Int,Word,Float,Double all can be register allocated+   let fmt = cmmTypeFormat pk in+        RegVirtual (mkVirtualReg u fmt) -getRegisterReg platform _ (CmmGlobal mid)+getRegisterReg platform  (CmmGlobal mid)   = case globalRegMaybe platform mid of         Just reg -> RegReal $ reg         Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)@@ -643,15 +648,14 @@             do reg' <- getPicBaseNat (archWordFormat is32Bit)                return (Fixed (archWordFormat is32Bit) reg' nilOL)         _ ->-            do use_sse2 <- sse2Enabled+            do                let                  fmt = cmmTypeFormat (cmmRegType dflags reg)-                 format | not use_sse2 && isFloatFormat fmt = FF80-                        | otherwise                         = fmt+                 format  = fmt                --                let platform = targetPlatform dflags                return (Fixed format-                             (getRegisterReg platform use_sse2 reg)+                             (getRegisterReg platform  reg)                              nilOL)  @@ -661,7 +665,7 @@ getRegister' dflags is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e])   = addAlignmentCheck align <$> getRegister' dflags is32Bit e --- for 32-bit architectuers, support some 64 -> 32 bit conversions:+-- for 32-bit architectures, support some 64 -> 32 bit conversions: -- TO_W_(x), TO_W_(x >> 32)  getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32)@@ -687,8 +691,7 @@   return $ Fixed II32 rlo code  getRegister' _ _ (CmmLit lit@(CmmFloat f w)) =-  if_sse2 float_const_sse2 float_const_x87- where+  float_const_sse2  where   float_const_sse2     | f == 0.0 = do       let@@ -699,22 +702,8 @@       return (Any format code)     | otherwise = do-      Amode addr code <- memConstant (widthInBytes w) lit-      loadFloatAmode True w addr code--  float_const_x87 = case w of-    W64-      | f == 0.0 ->-        let code dst = unitOL (GLDZ dst)-        in  return (Any FF80 code)--      | f == 1.0 ->-        let code dst = unitOL (GLD1 dst)-        in  return (Any FF80 code)--    _otherwise -> do-      Amode addr code <- memConstant (widthInBytes w) lit-      loadFloatAmode False w addr code+      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit+      loadFloatAmode w addr code  -- catch simple cases of zero- or sign-extended load getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do@@ -771,12 +760,10 @@         LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))  getRegister' dflags is32Bit (CmmMachOp mop [x]) = do -- unary MachOps-    sse2 <- sse2Enabled     case mop of-      MO_F_Neg w-         | sse2      -> sse2NegCode w x-         | otherwise -> trivialUFCode FF80 (GNEG FF80) x+      MO_F_Neg w  -> sse2NegCode w x +       MO_S_Neg w -> triv_ucode NEGI (intFormat w)       MO_Not w   -> triv_ucode NOT  (intFormat w) @@ -841,10 +828,9 @@       MO_XX_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOV x       MO_XX_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOV x -      MO_FF_Conv W32 W64-        | sse2      -> coerceFP2FP W64 x-        | otherwise -> conversionNop FF80 x+      MO_FF_Conv W32 W64 -> coerceFP2FP W64 x +       MO_FF_Conv W64 W32 -> coerceFP2FP W32 x        MO_FS_Conv from to -> coerceFP2Int from to x@@ -906,7 +892,6 @@   getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps-  sse2 <- sse2Enabled   case mop of       MO_F_Eq _ -> condFltReg is32Bit EQQ x y       MO_F_Ne _ -> condFltReg is32Bit NE  x y@@ -930,15 +915,15 @@       MO_U_Lt _ -> condIntReg LU  x y       MO_U_Le _ -> condIntReg LEU x y -      MO_F_Add w  | sse2      -> trivialFCode_sse2 w ADD  x y-                  | otherwise -> trivialFCode_x87    GADD x y-      MO_F_Sub w  | sse2      -> trivialFCode_sse2 w SUB  x y-                  | otherwise -> trivialFCode_x87    GSUB x y-      MO_F_Quot w | sse2      -> trivialFCode_sse2 w FDIV x y-                  | otherwise -> trivialFCode_x87    GDIV x y-      MO_F_Mul w  | sse2      -> trivialFCode_sse2 w MUL x y-                  | otherwise -> trivialFCode_x87    GMUL x y+      MO_F_Add w   -> trivialFCode_sse2 w ADD  x y +      MO_F_Sub w   -> trivialFCode_sse2 w SUB  x y++      MO_F_Quot w  -> trivialFCode_sse2 w FDIV x y++      MO_F_Mul w   -> trivialFCode_sse2 w MUL x y++       MO_Add rep -> add_code rep x y       MO_Sub rep -> sub_code rep x y @@ -1131,8 +1116,7 @@   | isFloatType pk   = do     Amode addr mem_code <- getAmode mem-    use_sse2 <- sse2Enabled-    loadFloatAmode use_sse2 (typeWidth pk) addr mem_code+    loadFloatAmode  (typeWidth pk) addr mem_code  getRegister' _ is32Bit (CmmLoad mem pk)   | is32Bit && not (isWord64 pk)@@ -1262,9 +1246,7 @@                 return (reg, code)  reg2reg :: Format -> Reg -> Reg -> Instr-reg2reg format src dst-  | format == FF80 = GMOV src dst-  | otherwise    = MOV format (OpReg src) (OpReg dst)+reg2reg format src dst = MOV format (OpReg src) (OpReg dst)   --------------------------------------------------------------------------------@@ -1373,11 +1355,10 @@  getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock) getNonClobberedOperand (CmmLit lit) = do-  use_sse2 <- sse2Enabled-  if use_sse2 && isSuitableFloatingPointLit lit+  if  isSuitableFloatingPointLit lit     then do       let CmmFloat _ w = lit-      Amode addr code <- memConstant (widthInBytes w) lit+      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit       return (OpAddr addr, code)      else do @@ -1389,9 +1370,12 @@  getNonClobberedOperand (CmmLoad mem pk) = do   is32Bit <- is32BitPlatform-  use_sse2 <- sse2Enabled-  if (not (isFloatType pk) || use_sse2)-      && (if is32Bit then not (isWord64 pk) else True)+  -- this logic could be simplified+  -- TODO FIXME+  if   (if is32Bit then not (isWord64 pk) else True)+      -- if 32bit and pk is at float/double/simd value+      -- or if 64bit+      --  this could use some eyeballs or i'll need to stare at it more later     then do       dflags <- getDynFlags       let platform = targetPlatform dflags@@ -1408,6 +1392,7 @@                    return (src, nilOL)       return (OpAddr src', mem_code `appOL` save_code)     else do+      -- if its a word or gcptr on 32bit?       getNonClobberedOperand_generic (CmmLoad mem pk)  getNonClobberedOperand e = getNonClobberedOperand_generic e@@ -1433,7 +1418,7 @@   if (use_sse2 && isSuitableFloatingPointLit lit)     then do       let CmmFloat _ w = lit-      Amode addr code <- memConstant (widthInBytes w) lit+      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit       return (OpAddr addr, code)     else do @@ -1481,7 +1466,7 @@              , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel              ] -memConstant :: Int -> CmmLit -> NatM Amode+memConstant :: Alignment -> CmmLit -> NatM Amode memConstant align lit = do   lbl <- getNewLabelNat   let rosection = Section ReadOnlyData lbl@@ -1500,16 +1485,15 @@   return (Amode addr code)  -loadFloatAmode :: Bool -> Width -> AddrMode -> InstrBlock -> NatM Register-loadFloatAmode use_sse2 w addr addr_code = do+loadFloatAmode :: Width -> AddrMode -> InstrBlock -> NatM Register+loadFloatAmode w addr addr_code = do   let format = floatFormat w       code dst = addr_code `snocOL`-                 if use_sse2-                    then MOV format (OpAddr addr) (OpReg dst)-                    else GLD format addr dst-  return (Any (if use_sse2 then format else FF80) code)+                    MOV format (OpAddr addr) (OpReg dst) +  return (Any format code) + -- if we want a floating-point literal as an operand, we can -- use it directly from memory.  However, if the literal is -- zero, we're better off generating it into a register using@@ -1668,19 +1652,9 @@ condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode  condFltCode cond x y-  = if_sse2 condFltCode_sse2 condFltCode_x87+  =  condFltCode_sse2   where -  condFltCode_x87-    = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT])) do-    (x_reg, x_code) <- getNonClobberedReg x-    (y_reg, y_code) <- getSomeReg y-    let-        code = x_code `appOL` y_code `snocOL`-                GCMP cond x_reg y_reg-    -- The GCMP insn does the test and sets the zero flag if comparable-    -- and true.  Hence we always supply EQQ as the condition to test.-    return (CondCode True EQQ code)    -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be   -- an operand, but the right must be a reg.  We can probably do better@@ -1764,35 +1738,33 @@   load_code <- intLoadCode (MOV pk) src   dflags <- getDynFlags   let platform = targetPlatform dflags-  return (load_code (getRegisterReg platform False{-no sse2-} reg))+  return (load_code (getRegisterReg platform reg))  -- dst is a reg, but src could be anything assignReg_IntCode _ reg src = do   dflags <- getDynFlags   let platform = targetPlatform dflags   code <- getAnyReg src-  return (code (getRegisterReg platform False{-no sse2-} reg))+  return (code (getRegisterReg platform reg))   -- Floating point assignment to memory assignMem_FltCode pk addr src = do   (src_reg, src_code) <- getNonClobberedReg src   Amode addr addr_code <- getAmode addr-  use_sse2 <- sse2Enabled   let         code = src_code `appOL`                addr_code `snocOL`-                if use_sse2 then MOV pk (OpReg src_reg) (OpAddr addr)-                            else GST pk src_reg addr+               MOV pk (OpReg src_reg) (OpAddr addr)+   return code  -- Floating point assignment to a register/temporary assignReg_FltCode _ reg src = do-  use_sse2 <- sse2Enabled   src_code <- getAnyReg src   dflags <- getDynFlags   let platform = targetPlatform dflags-  return (src_code (getRegisterReg platform use_sse2 reg))+  return (src_code (getRegisterReg platform  reg))   genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock@@ -2014,6 +1986,9 @@ -- -- (If applicable) Do not fill the delay slots here; you will confuse the -- register allocator.+--+-- See Note [Keeping track of the current block] for information why we need+-- to take/return a block id.  genCCall     :: DynFlags@@ -2028,7 +2003,6 @@  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@@ -2036,7 +2010,7 @@     arg <- getNewRegNat format     arg_code <- getAnyReg n     let platform = targetPlatform dflags-        dst_r    = getRegisterReg platform use_sse2 (CmmLocal dst)+        dst_r    = getRegisterReg platform  (CmmLocal dst)     (code, lbl) <- op_code dst_r arg amode     return (addr_code `appOL` arg_code arg `appOL` code, Just lbl)   where@@ -2103,9 +2077,8 @@ 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)+          dst_r   = getRegisterReg platform  (CmmLocal dst)       lbl1 <- getBlockIdNat       lbl2 <- getBlockIdNat       let format = if width == W8 then II16 else intFormat width@@ -2126,7 +2099,7 @@       --  } else {       --    dst = 64;       --  }-      let instrs = vcode `appOL` toOL+      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)@@ -2146,23 +2119,37 @@    | otherwise = do     code_src <- getAnyReg src-    use_sse2 <- sse2Enabled-    let dst_r = getRegisterReg platform use_sse2 (CmmLocal dst)+    let dst_r = getRegisterReg platform (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)+    if isBmi2Enabled dflags+    then do+        src_r <- getNewRegNat (intFormat width)+        let instrs = appOL (code_src src_r) $ case width of+                W8 -> toOL+                    [ OR    II32 (OpImm (ImmInteger 0xFFFFFF00)) (OpReg src_r)+                    , TZCNT II32 (OpReg src_r)        dst_r+                    ]+                W16 -> toOL+                    [ TZCNT  II16 (OpReg src_r) dst_r+                    , MOVZxL II16 (OpReg dst_r) (OpReg dst_r)+                    ]+                _ -> unitOL $ TZCNT (intFormat width) (OpReg src_r) dst_r+        return (instrs, Nothing)+    else do+        -- 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@@ -2183,9 +2170,9 @@  -- 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 _ (PrimTarget (MO_Memcpy align)) _          [dst, src, CmmLit (CmmInt n _)] _-    | fromInteger insns <= maxInlineMemcpyInsns dflags && align .&. 3 == 0 = do+    | fromInteger insns <= maxInlineMemcpyInsns dflags = do         code_dst <- getAnyReg dst         dst_r <- getNewRegNat format         code_src <- getAnyReg src@@ -2198,7 +2185,9 @@     -- instructions per move.     insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes) -    format = if align .&. 4 /= 0 then II32 else (archWordFormat is32Bit)+    maxAlignment = wordAlignment dflags -- only machine word wide MOVs are supported+    effectiveAlignment = min (alignmentOf align) maxAlignment+    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment      -- The size of each move, in bytes.     sizeBytes :: Integer@@ -2235,17 +2224,25 @@           CmmLit (CmmInt c _),           CmmLit (CmmInt n _)]          _-    | fromInteger insns <= maxInlineMemsetInsns dflags && align .&. 3 == 0 = do+    | fromInteger insns <= maxInlineMemsetInsns dflags = do         code_dst <- getAnyReg dst         dst_r <- getNewRegNat format-        return $ code_dst dst_r `appOL` go dst_r (fromInteger n)+        if format == II64 && n >= 8 then do+          code_imm8byte <- getAnyReg (CmmLit (CmmInt c8 W64))+          imm8byte_r <- getNewRegNat II64+          return $ code_dst dst_r `appOL`+                   code_imm8byte imm8byte_r `appOL`+                   go8 dst_r imm8byte_r (fromInteger n)+        else+          return $ code_dst dst_r `appOL`+                   go4 dst_r (fromInteger n)   where-    (format, val) = case align .&. 3 of-        2 -> (II16, c2)-        0 -> (II32, c4)-        _ -> (II8, c)+    maxAlignment = wordAlignment dflags -- only machine word wide MOVs are supported+    effectiveAlignment = min (alignmentOf align) maxAlignment+    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment     c2 = c `shiftL` 8 .|. c     c4 = c2 `shiftL` 16 .|. c2+    c8 = c4 `shiftL` 32 .|. c4      -- The number of instructions we will generate (approx). We need 1     -- instructions per move.@@ -2255,26 +2252,46 @@     sizeBytes :: Integer     sizeBytes = fromIntegral (formatInBytes format) -    go :: Reg -> Integer -> OrdList Instr-    go dst i-        -- TODO: Add movabs instruction and support 64-bit sets.-        | i >= sizeBytes =  -- This might be smaller than the below sizes-            unitOL (MOV format (OpImm (ImmInteger val)) (OpAddr dst_addr)) `appOL`-            go dst (i - sizeBytes)-        | i >= 4 =  -- Will never happen on 32-bit-            unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr dst_addr)) `appOL`-            go dst (i - 4)-        | i >= 2 =-            unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr dst_addr)) `appOL`-            go dst (i - 2)-        | i >= 1 =-            unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr dst_addr)) `appOL`-            go dst (i - 1)-        | otherwise = nilOL+    -- Depending on size returns the widest MOV instruction and its+    -- width.+    gen4 :: AddrMode -> Integer -> (InstrBlock, Integer)+    gen4 addr size+        | size >= 4 =+            (unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr addr)), 4)+        | size >= 2 =+            (unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr addr)), 2)+        | size >= 1 =+            (unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr addr)), 1)+        | otherwise = (nilOL, 0)++    -- Generates a 64-bit wide MOV instruction from REG to MEM.+    gen8 :: AddrMode -> Reg -> InstrBlock+    gen8 addr reg8byte =+      unitOL (MOV format (OpReg reg8byte) (OpAddr addr))++    -- Unrolls memset when the widest MOV is <= 4 bytes.+    go4 :: Reg -> Integer -> InstrBlock+    go4 dst left =+      if left <= 0 then nilOL+      else curMov `appOL` go4 dst (left - curWidth)       where-        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone-                   (ImmInteger (n - i))+        possibleWidth = minimum [left, sizeBytes]+        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))+        (curMov, curWidth) = gen4 dst_addr possibleWidth +    -- Unrolls memset when the widest MOV is 8 bytes (thus another Reg+    -- argument). Falls back to go4 when all 8 byte moves are+    -- exhausted.+    go8 :: Reg -> Reg -> Integer -> InstrBlock+    go8 dst reg8byte left =+      if possibleWidth >= 8 then+        let curMov = gen8 dst_addr reg8byte+        in  curMov `appOL` go8 dst reg8byte (left - 8)+      else go4 dst left+      where+        possibleWidth = minimum [left, sizeBytes]+        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))+ genCCall' _ _ (PrimTarget MO_ReadBarrier) _ _ _  = return nilOL genCCall' _ _ (PrimTarget MO_WriteBarrier) _ _ _ = return nilOL         -- barriers compile to no code on x86/x86-64;@@ -2305,8 +2322,7 @@  genCCall' dflags is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] _ = do     let platform = targetPlatform dflags-    use_sse2 <- sse2Enabled-    let dst_r = getRegisterReg platform use_sse2 (CmmLocal dst)+    let dst_r = getRegisterReg platform (CmmLocal dst)     case width of         W64 | is32Bit -> do                ChildCode64 vcode rlo <- iselExpr64 src@@ -2333,7 +2349,7 @@     if sse4_2         then do code_src <- getAnyReg src                 src_r <- getNewRegNat format-                let dst_r = getRegisterReg platform False (CmmLocal dst)+                let dst_r = getRegisterReg platform  (CmmLocal dst)                 return $ code_src src_r `appOL`                     (if width == W8 then                          -- The POPCNT instruction doesn't take a r/m8@@ -2360,13 +2376,12 @@ 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 use_sse2 (CmmLocal dst)+                let dst_r = getRegisterReg platform  (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@@ -2394,13 +2409,12 @@ 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 use_sse2 (CmmLocal dst)+                let dst_r = getRegisterReg platform  (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@@ -2436,25 +2450,37 @@    | 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 'clz 0' has a defined value.-    -- starting with Haswell, one could use the LZCNT insn instead.-    return $ code_src src_r `appOL` toOL-             ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] ++-              [ BSR     format (OpReg src_r) tmp_r-              , MOV     II32   (OpImm (ImmInt (2*bw-1))) (OpReg dst_r)-              , CMOV NE format (OpReg tmp_r) dst_r-              , XOR     format (OpImm (ImmInt (bw-1))) (OpReg 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+    let dst_r = getRegisterReg platform (CmmLocal dst)+    if isBmi2Enabled dflags+        then do+            src_r <- getNewRegNat (intFormat width)+            return $ appOL (code_src src_r) $ case width of+                W8 -> toOL+                    [ MOVZxL II8  (OpReg src_r)       (OpReg src_r) -- zero-extend to 32 bit+                    , LZCNT  II32 (OpReg src_r)       dst_r         -- lzcnt with extra 24 zeros+                    , SUB    II32 (OpImm (ImmInt 24)) (OpReg dst_r) -- compensate for extra zeros+                    ]+                W16 -> toOL+                    [ LZCNT  II16 (OpReg src_r) dst_r+                    , MOVZxL II16 (OpReg dst_r) (OpReg dst_r) -- zero-extend from 16 bit+                    ]+                _ -> unitOL (LZCNT (intFormat width) (OpReg src_r) dst_r)+        else do+            let format = if width == W8 then II16 else intFormat width+            src_r <- getNewRegNat format+            tmp_r <- getNewRegNat format+            return $ code_src src_r `appOL` toOL+                     ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] +++                      [ BSR     format (OpReg src_r) tmp_r+                      , MOV     II32   (OpImm (ImmInt (2*bw-1))) (OpReg dst_r)+                      , CMOV NE format (OpReg tmp_r) dst_r+                      , XOR     format (OpImm (ImmInt (bw-1))) (OpReg 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     lbl = mkCmmCodeLabel primUnitId (fsLit (clzLabel width))  genCCall' dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do@@ -2470,9 +2496,8 @@ 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)))+  return (load_code (getRegisterReg platform  (CmmLocal dst)))  genCCall' _ _ (PrimTarget (MO_AtomicWrite width)) [] [addr, val] _ = do     code <- assignMem_IntCode (intFormat width) addr val@@ -2482,14 +2507,13 @@     -- 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     let platform = targetPlatform dflags-        dst_r    = getRegisterReg platform use_sse2 (CmmLocal dst)+        dst_r    = getRegisterReg platform  (CmmLocal dst)         code     = toOL                    [ MOV format (OpReg oldval) (OpReg eax)                    , LOCK (CMPXCHG format (OpReg newval) (OpAddr amode))@@ -2503,14 +2527,12 @@ genCCall' _ is32Bit target dest_regs args bid = do   dflags <- getDynFlags   let platform = targetPlatform dflags-      sse2     = isSse2Enabled dflags   case (target, dest_regs) of     -- void return type prim op     (PrimTarget op, []) ->         outOfLineCmmOp bid op Nothing args     -- we only cope with a single result for foreign calls-    (PrimTarget op, [r])-      | sse2 -> case op of+    (PrimTarget op, [r])  -> case op of           MO_F32_Fabs -> case args of             [x] -> sse2FabsCode W32 x             _ -> panic "genCCall: Wrong number of arguments for fabs"@@ -2521,36 +2543,16 @@           MO_F32_Sqrt -> actuallyInlineSSE2Op (\fmt r -> SQRT fmt (OpReg r)) FF32 args           MO_F64_Sqrt -> actuallyInlineSSE2Op (\fmt r -> SQRT fmt (OpReg r)) FF64 args           _other_op -> outOfLineCmmOp bid op (Just r) args-      | otherwise -> do-        l1 <- getNewLabelNat-        l2 <- getNewLabelNat-        if sse2-          then outOfLineCmmOp bid op (Just r) args-          else case op of-              MO_F32_Sqrt -> actuallyInlineFloatOp GSQRT FF32 args-              MO_F64_Sqrt -> actuallyInlineFloatOp GSQRT FF64 args -              MO_F32_Sin  -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF32 args-              MO_F64_Sin  -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF64 args--              MO_F32_Cos  -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF32 args-              MO_F64_Cos  -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF64 args--              MO_F32_Tan  -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args-              MO_F64_Tan  -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args--              _other_op   -> outOfLineCmmOp bid op (Just r) args-        where-        actuallyInlineFloatOp = actuallyInlineFloatOp' False-        actuallyInlineSSE2Op = actuallyInlineFloatOp' True+        actuallyInlineSSE2Op = actuallyInlineFloatOp' -        actuallyInlineFloatOp' usesSSE instr format [x]+        actuallyInlineFloatOp'  instr format [x]               = do res <- trivialUFCode format (instr format) x                    any <- anyReg res-                   return (any (getRegisterReg platform usesSSE (CmmLocal r)))+                   return (any (getRegisterReg platform  (CmmLocal r))) -        actuallyInlineFloatOp' _ _ _ args+        actuallyInlineFloatOp' _ _ args               = panic $ "genCCall.actuallyInlineFloatOp': bad number of arguments! ("                       ++ show (length args) ++ ")" @@ -2561,7 +2563,7 @@           let             const | FF32 <- fmt = CmmInt 0x7fffffff W32                   | otherwise   = CmmInt 0x7fffffffffffffff W64-          Amode amode amode_code <- memConstant (widthInBytes w) const+          Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const           tmp <- getNewRegNat fmt           let             code dst = x_code dst `appOL` amode_code `appOL` toOL [@@ -2569,7 +2571,7 @@                 AND fmt (OpReg tmp) (OpReg dst)                 ] -          return $ code (getRegisterReg platform True (CmmLocal r))+          return $ code (getRegisterReg platform (CmmLocal r))      (PrimTarget (MO_S_QuotRem  width), _) -> divOp1 platform True  width dest_regs args     (PrimTarget (MO_U_QuotRem  width), _) -> divOp1 platform False width dest_regs args@@ -2581,8 +2583,8 @@                let format = intFormat width                lCode <- anyReg =<< trivialCode width (ADD_CC format)                                      (Just (ADD_CC format)) arg_x arg_y-               let reg_l = getRegisterReg platform True (CmmLocal res_l)-                   reg_h = getRegisterReg platform True (CmmLocal res_h)+               let reg_l = getRegisterReg platform (CmmLocal res_l)+                   reg_h = getRegisterReg platform (CmmLocal res_h)                    code = hCode reg_h `appOL`                           lCode reg_l `snocOL`                           ADC format (OpImm (ImmInteger 0)) (OpReg reg_h)@@ -2602,8 +2604,8 @@             do (y_reg, y_code) <- getRegOrMem arg_y                x_code <- getAnyReg arg_x                let format = intFormat width-                   reg_h = getRegisterReg platform True (CmmLocal res_h)-                   reg_l = getRegisterReg platform True (CmmLocal res_l)+                   reg_h = getRegisterReg platform (CmmLocal res_h)+                   reg_l = getRegisterReg platform (CmmLocal res_l)                    code = y_code `appOL`                           x_code rax `appOL`                           toOL [MUL2 format y_reg,@@ -2639,8 +2641,8 @@         divOp platform signed width [res_q, res_r]               m_arg_x_high arg_x_low arg_y             = do let format = intFormat width-                     reg_q = getRegisterReg platform True (CmmLocal res_q)-                     reg_r = getRegisterReg platform True (CmmLocal res_r)+                     reg_q = getRegisterReg platform (CmmLocal res_q)+                     reg_r = getRegisterReg platform (CmmLocal res_r)                      widen | signed    = CLTD format                            | otherwise = XOR format (OpReg rdx) (OpReg rdx)                      instr | signed    = IDIV@@ -2667,8 +2669,8 @@                  rCode <- anyReg =<< trivialCode width (instr format)                                        (mrevinstr format) arg_x arg_y                  reg_tmp <- getNewRegNat II8-                 let reg_c = getRegisterReg platform True (CmmLocal res_c)-                     reg_r = getRegisterReg platform True (CmmLocal res_r)+                 let reg_c = getRegisterReg platform  (CmmLocal res_c)+                     reg_r = getRegisterReg platform  (CmmLocal res_r)                      code = rCode reg_r `snocOL`                             SETCC cond (OpReg reg_tmp) `snocOL`                             MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)@@ -2712,8 +2714,7 @@         delta0 <- getDeltaNat         setDeltaNat (delta0 - arg_pad_size) -        use_sse2 <- sse2Enabled-        push_codes <- mapM (push_arg use_sse2) (reverse prom_args)+        push_codes <- mapM push_arg (reverse prom_args)         delta <- getDeltaNat         MASSERT(delta == delta0 - tot_arg_size) @@ -2766,18 +2767,21 @@             assign_code []     = nilOL             assign_code [dest]               | isFloatType ty =-                 if use_sse2-                    then let tmp_amode = AddrBaseIndex (EABaseReg esp)+                  -- we assume SSE2+                  let tmp_amode = AddrBaseIndex (EABaseReg esp)                                                        EAIndexNone                                                        (ImmInt 0)-                             fmt = floatFormat w+                      fmt = floatFormat w                          in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp),                                    DELTA (delta0 - b),-                                   GST fmt fake0 tmp_amode,+                                   X87Store fmt  tmp_amode,+                                   -- X87Store only supported for the CDECL ABI+                                   -- NB: This code will need to be+                                   -- revisted once GHC does more work around+                                   -- SIGFPE f                                    MOV fmt (OpAddr tmp_amode) (OpReg r_dest),                                    ADD II32 (OpImm (ImmInt b)) (OpReg esp),                                    DELTA delta0]-                    else unitOL (GMOV fake0 r_dest)               | isWord64 ty    = toOL [MOV II32 (OpReg eax) (OpReg r_dest),                                         MOV II32 (OpReg edx) (OpReg r_dest_hi)]               | otherwise      = unitOL (MOV (intFormat w)@@ -2788,7 +2792,7 @@                     w  = typeWidth ty                     b  = widthInBytes w                     r_dest_hi = getHiVRegFromLo r_dest-                    r_dest    = getRegisterReg platform use_sse2 (CmmLocal dest)+                    r_dest    = getRegisterReg platform  (CmmLocal dest)             assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many)          return (push_code `appOL`@@ -2803,10 +2807,10 @@         roundTo a x | x `mod` a == 0 = x                     | otherwise = x + a - (x `mod` a) -        push_arg :: Bool -> CmmActual {-current argument-}+        push_arg :: CmmActual {-current argument-}                         -> NatM InstrBlock  -- code -        push_arg use_sse2 arg -- we don't need the hints on x86+        push_arg  arg -- we don't need the hints on x86           | isWord64 arg_ty = do             ChildCode64 code r_lo <- iselExpr64 arg             delta <- getDeltaNat@@ -2830,9 +2834,10 @@                                                             (ImmInt 0)                                       format = floatFormat (typeWidth arg_ty)                                   in-                                  if use_sse2-                                     then MOV format (OpReg reg) (OpAddr addr)-                                     else GST format reg addr++                                  -- assume SSE2+                                   MOV format (OpReg reg) (OpAddr addr)+                                  ]                            ) @@ -2960,7 +2965,7 @@                 _ -> unitOL (MOV (cmmTypeFormat rep) (OpReg rax) (OpReg r_dest))           where                 rep = localRegType dest-                r_dest = getRegisterReg platform True (CmmLocal dest)+                r_dest = getRegisterReg platform  (CmmLocal dest)         assign_code _many = panic "genCCall.assign_code many"      return (adjust_rsp          `appOL`@@ -3118,6 +3123,8 @@       let target = ForeignTarget targetExpr                            (ForeignConvention CCallConv [] [] CmmMayReturn) +      -- We know foreign calls results in no new basic blocks, so we can ignore+      -- the returned block id.       (instrs, _) <- stmtToInstrs bid (CmmUnsafeForeignCall target (catMaybes [res]) args)       return instrs   where@@ -3133,7 +3140,9 @@               MO_F32_Cos   -> fsLit "cosf"               MO_F32_Tan   -> fsLit "tanf"               MO_F32_Exp   -> fsLit "expf"+              MO_F32_ExpM1 -> fsLit "expm1f"               MO_F32_Log   -> fsLit "logf"+              MO_F32_Log1P -> fsLit "log1pf"                MO_F32_Asin  -> fsLit "asinf"               MO_F32_Acos  -> fsLit "acosf"@@ -3154,7 +3163,9 @@               MO_F64_Cos   -> fsLit "cos"               MO_F64_Tan   -> fsLit "tan"               MO_F64_Exp   -> fsLit "exp"+              MO_F64_ExpM1 -> fsLit "expm1"               MO_F64_Log   -> fsLit "log"+              MO_F64_Log1P -> fsLit "log1p"                MO_F64_Asin  -> fsLit "asin"               MO_F64_Acos  -> fsLit "acos"@@ -3176,6 +3187,10 @@                MO_PopCnt _  -> fsLit "popcnt"               MO_BSwap _   -> fsLit "bswap"+              {- Here the C implementation is used as there is no x86+              instruction to reverse a word's bit order.+              -}+              MO_BRev w    -> fsLit $ bRevLabel w               MO_Clz w     -> fsLit $ clzLabel w               MO_Ctz _     -> unsupported @@ -3288,7 +3303,7 @@                           where blockLabel = blockLbl blockid                   in map jumpTableEntryRel ids             | otherwise = map (jumpTableEntry dflags) ids-      in CmmData section (1, Statics lbl jumpTable)+      in CmmData section (mkAlignment 1, Statics lbl jumpTable)  extractUnwindPoints :: [Instr] -> [UnwindPoint] extractUnwindPoints instrs =@@ -3371,18 +3386,10 @@ -- and plays better with the uOP cache.  condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register-condFltReg is32Bit cond x y = if_sse2 condFltReg_sse2 condFltReg_x87+condFltReg is32Bit cond x y = condFltReg_sse2  where-  condFltReg_x87 = do-    CondCode _ cond cond_code <- condFltCode cond x y-    tmp <- getNewRegNat II8-    let-        code dst = cond_code `appOL` toOL [-                    SETCC cond (OpReg tmp),-                    MOVZxL II8 (OpReg tmp) (OpReg dst)-                  ]-    return (Any II32 code) +   condFltReg_sse2 = do     CondCode _ cond cond_code <- condFltCode cond x y     tmp1 <- getNewRegNat (archWordFormat is32Bit)@@ -3545,18 +3552,6 @@  ----------- -trivialFCode_x87 :: (Format -> Reg -> Reg -> Reg -> Instr)-                 -> CmmExpr -> CmmExpr -> NatM Register-trivialFCode_x87 instr x y = do-  (x_reg, x_code) <- getNonClobberedReg x -- these work for float regs too-  (y_reg, y_code) <- getSomeReg y-  let-     format = FF80 -- always, on x87-     code dst =-        x_code `appOL`-        y_code `snocOL`-        instr format x_reg y_reg dst-  return (Any format code)  trivialFCode_sse2 :: Width -> (Format -> Operand -> Operand -> Instr)                   -> CmmExpr -> CmmExpr -> NatM Register@@ -3577,17 +3572,8 @@  -------------------------------------------------------------------------------- coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register-coerceInt2FP from to x = if_sse2 coerce_sse2 coerce_x87+coerceInt2FP from to x =  coerce_sse2  where-   coerce_x87 = do-     (x_reg, x_code) <- getSomeReg x-     let-           opc  = case to of W32 -> GITOF; W64 -> GITOD;-                             n -> panic $ "coerceInt2FP.x87: unhandled width ("-                                         ++ show n ++ ")"-           code dst = x_code `snocOL` opc x_reg dst-        -- ToDo: works for non-II32 reps?-     return (Any FF80 code)     coerce_sse2 = do      (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand@@ -3601,18 +3587,8 @@  -------------------------------------------------------------------------------- coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register-coerceFP2Int from to x = if_sse2 coerceFP2Int_sse2 coerceFP2Int_x87+coerceFP2Int from to x =  coerceFP2Int_sse2  where-   coerceFP2Int_x87 = do-     (x_reg, x_code) <- getSomeReg x-     let-           opc  = case from of W32 -> GFTOI; W64 -> GDTOI-                               n -> panic $ "coerceFP2Int.x87: unhandled width ("-                                           ++ show n ++ ")"-           code dst = x_code `snocOL` opc x_reg dst-        -- ToDo: works for non-II32 reps?-     return (Any (intFormat to) code)-    coerceFP2Int_sse2 = do      (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand      let@@ -3627,15 +3603,13 @@ -------------------------------------------------------------------------------- coerceFP2FP :: Width -> CmmExpr -> NatM Register coerceFP2FP to x = do-  use_sse2 <- sse2Enabled   (x_reg, x_code) <- getSomeReg x   let-        opc | use_sse2  = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD;+        opc  = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD;                                      n -> panic $ "coerceFP2FP: unhandled width ("                                                  ++ show n ++ ")"-            | otherwise = GDTOF         code dst = x_code `snocOL` opc x_reg dst-  return (Any (if use_sse2 then floatFormat to else FF80) code)+  return (Any ( floatFormat to) code)  -------------------------------------------------------------------------------- @@ -3652,10 +3626,10 @@       x@II16 -> wrongFmt x       x@II32 -> wrongFmt x       x@II64 -> wrongFmt x-      x@FF80 -> wrongFmt x+       where         wrongFmt x = panic $ "sse2NegCode: " ++ show x-  Amode amode amode_code <- memConstant (widthInBytes w) const+  Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const   tmp <- getNewRegNat fmt   let     code dst = x_code dst `appOL` amode_code `appOL` toOL [@@ -3692,7 +3666,7 @@ -- | 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.---   We depend on the information in the CFG to do so. Without a given CFG+--   We depend on the information in the CFG to do so so without a given CFG --   we do nothing. invertCondBranches :: Maybe CFG  -- ^ CFG if present                    -> LabelMap a -- ^ Blocks with info tables@@ -3718,7 +3692,7 @@       , Just edgeInfo2 <- getEdgeInfo lbl1 target2 cfg       -- Both jumps come from the same cmm statement       , transitionSource edgeInfo1 == transitionSource edgeInfo2-      , CmmSource cmmCondBranch <- transitionSource edgeInfo1+      , CmmSource {trans_cmmNode = cmmCondBranch} <- transitionSource edgeInfo1        --Int comparisons are invertable       , CmmCondBranch (CmmMachOp op _args) _ _ _ <- cmmCondBranch
compiler/nativeGen/X86/Instr.hs view
@@ -10,12 +10,11 @@  module X86.Instr (Instr(..), Operand(..), PrefetchVariant(..), JumpDest(..),                   getJumpDestBlockId, canShortcut, shortcutStatics,-                  shortcutJump, i386_insert_ffrees, allocMoreStack,+                  shortcutJump, allocMoreStack,                   maxSpillSlots, archWordFormat ) where -#include "GhclibHsVersions.h"-#include "nativeGen/NCG.h"+#include "HsVersions.h"  import GhcPrelude @@ -30,11 +29,11 @@ import BlockId import Hoopl.Collections import Hoopl.Label-import CodeGen.Platform+import GHC.Platform.Regs import Cmm import FastString import Outputable-import Platform+import GHC.Platform  import BasicTypes       (Alignment) import CLabel@@ -240,46 +239,14 @@         | BT          Format Imm Operand         | NOP -        -- x86 Float Arithmetic.-        -- Note that we cheat by treating G{ABS,MOV,NEG} of doubles-        -- as single instructions right up until we spit them out.-        -- all the 3-operand fake fp insns are src1 src2 dst-        -- and furthermore are constrained to be fp regs only.-        -- IMPORTANT: keep is_G_insn up to date with any changes here-        | GMOV        Reg Reg -- src(fpreg), dst(fpreg)-        | GLD         Format AddrMode Reg -- src, dst(fpreg)-        | GST         Format Reg AddrMode -- src(fpreg), dst -        | GLDZ        Reg -- dst(fpreg)-        | GLD1        Reg -- dst(fpreg)--        | GFTOI       Reg Reg -- src(fpreg), dst(intreg)-        | GDTOI       Reg Reg -- src(fpreg), dst(intreg)--        | GITOF       Reg Reg -- src(intreg), dst(fpreg)-        | GITOD       Reg Reg -- src(intreg), dst(fpreg)--        | GDTOF       Reg Reg -- src(fpreg), dst(fpreg)--        | GADD        Format Reg Reg Reg -- src1, src2, dst-        | GDIV        Format Reg Reg Reg -- src1, src2, dst-        | GSUB        Format Reg Reg Reg -- src1, src2, dst-        | GMUL        Format Reg Reg Reg -- src1, src2, dst--                -- FP compare.  Cond must be `elem` [EQQ, NE, LE, LTT, GE, GTT]-                -- Compare src1 with src2; set the Zero flag iff the numbers are-                -- comparable and the comparison is True.  Subsequent code must-                -- test the %eflags zero flag regardless of the supplied Cond.-        | GCMP        Cond Reg Reg -- src1, src2--        | GABS        Format Reg Reg -- src, dst-        | GNEG        Format Reg Reg -- src, dst-        | GSQRT       Format Reg Reg -- src, dst-        | GSIN        Format CLabel CLabel Reg Reg -- src, dst-        | GCOS        Format CLabel CLabel Reg Reg -- src, dst-        | GTAN        Format CLabel CLabel Reg Reg -- src, dst--        | GFREE         -- do ffree on all x86 regs; an ugly hack+        -- We need to support the FSTP (x87 store and pop) instruction+        -- so that we can correctly read off the return value of an+        -- x86 CDECL C function call when its floating point.+        -- so we dont include a register argument, and just use st(0)+        -- this instruction is used ONLY for return values of C ffi calls+        -- in x86_32 abi+        | X87Store         Format  AddrMode -- st(0), dst           -- SSE2 floating point: we use a restricted set of the available SSE2@@ -344,6 +311,8 @@      -- bit counting instructions         | POPCNT      Format Operand Reg -- [SSE4.2] count number of bits set to 1+        | LZCNT       Format Operand Reg -- [BMI2] count number of leading zeros+        | TZCNT       Format Operand Reg -- [BMI2] count number of trailing zeros         | BSF         Format Operand Reg -- bit scan forward         | BSR         Format Operand Reg -- bit scan reverse @@ -427,33 +396,7 @@     CLTD   _            -> mkRU [eax] [edx]     NOP                 -> mkRU [] [] -    GMOV   src dst      -> mkRU [src] [dst]-    GLD    _ src dst    -> mkRU (use_EA src []) [dst]-    GST    _ src dst    -> mkRUR (src : use_EA dst [])--    GLDZ   dst          -> mkRU [] [dst]-    GLD1   dst          -> mkRU [] [dst]--    GFTOI  src dst      -> mkRU [src] [dst]-    GDTOI  src dst      -> mkRU [src] [dst]--    GITOF  src dst      -> mkRU [src] [dst]-    GITOD  src dst      -> mkRU [src] [dst]--    GDTOF  src dst      -> mkRU [src] [dst]--    GADD   _ s1 s2 dst  -> mkRU [s1,s2] [dst]-    GSUB   _ s1 s2 dst  -> mkRU [s1,s2] [dst]-    GMUL   _ s1 s2 dst  -> mkRU [s1,s2] [dst]-    GDIV   _ s1 s2 dst  -> mkRU [s1,s2] [dst]--    GCMP   _ src1 src2   -> mkRUR [src1,src2]-    GABS   _ src dst     -> mkRU [src] [dst]-    GNEG   _ src dst     -> mkRU [src] [dst]-    GSQRT  _ src dst     -> mkRU [src] [dst]-    GSIN   _ _ _ src dst -> mkRU [src] [dst]-    GCOS   _ _ _ src dst -> mkRU [src] [dst]-    GTAN   _ _ _ src dst -> mkRU [src] [dst]+    X87Store    _  dst    -> mkRUR ( use_EA dst [])      CVTSS2SD   src dst  -> mkRU [src] [dst]     CVTSD2SS   src dst  -> mkRU [src] [dst]@@ -473,6 +416,8 @@     DELTA   _           -> noUsage      POPCNT _ src dst -> mkRU (use_R src []) [dst]+    LZCNT  _ src dst -> mkRU (use_R src []) [dst]+    TZCNT  _ src dst -> mkRU (use_R src []) [dst]     BSF    _ src dst -> mkRU (use_R src []) [dst]     BSR    _ src dst -> mkRU (use_R src []) [dst] @@ -601,33 +546,8 @@     JMP op regs          -> JMP (patchOp op) regs     JMP_TBL op ids s lbl -> JMP_TBL (patchOp op) ids s lbl -    GMOV src dst         -> GMOV (env src) (env dst)-    GLD  fmt src dst     -> GLD fmt (lookupAddr src) (env dst)-    GST  fmt src dst     -> GST fmt (env src) (lookupAddr dst)--    GLDZ dst            -> GLDZ (env dst)-    GLD1 dst            -> GLD1 (env dst)--    GFTOI src dst       -> GFTOI (env src) (env dst)-    GDTOI src dst       -> GDTOI (env src) (env dst)--    GITOF src dst       -> GITOF (env src) (env dst)-    GITOD src dst       -> GITOD (env src) (env dst)--    GDTOF src dst       -> GDTOF (env src) (env dst)--    GADD fmt s1 s2 dst   -> GADD fmt (env s1) (env s2) (env dst)-    GSUB fmt s1 s2 dst   -> GSUB fmt (env s1) (env s2) (env dst)-    GMUL fmt s1 s2 dst   -> GMUL fmt (env s1) (env s2) (env dst)-    GDIV fmt s1 s2 dst   -> GDIV fmt (env s1) (env s2) (env dst)--    GCMP fmt src1 src2   -> GCMP fmt (env src1) (env src2)-    GABS fmt src dst     -> GABS fmt (env src) (env dst)-    GNEG fmt src dst     -> GNEG fmt (env src) (env dst)-    GSQRT fmt src dst    -> GSQRT fmt (env src) (env dst)-    GSIN fmt l1 l2 src dst       -> GSIN fmt l1 l2 (env src) (env dst)-    GCOS fmt l1 l2 src dst       -> GCOS fmt l1 l2 (env src) (env dst)-    GTAN fmt l1 l2 src dst       -> GTAN fmt l1 l2 (env src) (env dst)+    -- literally only support storing the top x87 stack value st(0)+    X87Store  fmt  dst     -> X87Store fmt  (lookupAddr dst)      CVTSS2SD src dst    -> CVTSS2SD (env src) (env dst)     CVTSD2SS src dst    -> CVTSD2SS (env src) (env dst)@@ -655,6 +575,8 @@     CLTD _              -> instr      POPCNT fmt src dst -> POPCNT fmt (patchOp src) (env dst)+    LZCNT  fmt src dst -> LZCNT  fmt (patchOp src) (env dst)+    TZCNT  fmt src dst -> TZCNT  fmt (patchOp src) (env dst)     PDEP   fmt src mask dst -> PDEP   fmt (patchOp src) (patchOp mask) (env dst)     PEXT   fmt src mask dst -> PEXT   fmt (patchOp src) (patchOp mask) (env dst)     BSF    fmt src dst -> BSF    fmt (patchOp src) (env dst)@@ -748,8 +670,7 @@     case targetClassOfReg platform reg of            RcInteger   -> MOV (archWordFormat is32Bit)                               (OpReg reg) (OpAddr (spRel dflags off))-           RcDouble    -> GST FF80 reg (spRel dflags off) {- RcFloat/RcDouble -}-           RcDoubleSSE -> MOV FF64 (OpReg reg) (OpAddr (spRel dflags off))+           RcDouble    -> MOV FF64 (OpReg reg) (OpAddr (spRel dflags off))            _         -> panic "X86.mkSpillInstr: no match"     where platform = targetPlatform dflags           is32Bit = target32Bit platform@@ -768,8 +689,7 @@         case targetClassOfReg platform reg of               RcInteger -> MOV (archWordFormat is32Bit)                                (OpAddr (spRel dflags off)) (OpReg reg)-              RcDouble  -> GLD FF80 (spRel dflags off) reg {- RcFloat/RcDouble -}-              RcDoubleSSE -> MOV FF64 (OpAddr (spRel dflags off)) (OpReg reg)+              RcDouble  -> MOV FF64 (OpAddr (spRel dflags off)) (OpReg reg)               _           -> panic "X86.x86_mkLoadInstr"     where platform = targetPlatform dflags           is32Bit = target32Bit platform@@ -823,6 +743,7 @@   +---  TODO: why is there -- | Make a reg-reg move instruction. --      On SPARC v8 there are no instructions to move directly between --      floating point and integer regs. If we need to do that then we@@ -840,8 +761,10 @@                      ArchX86    -> MOV II32 (OpReg src) (OpReg dst)                      ArchX86_64 -> MOV II64 (OpReg src) (OpReg dst)                      _          -> panic "x86_mkRegRegMoveInstr: Bad arch"-        RcDouble    -> GMOV src dst-        RcDoubleSSE -> MOV FF64 (OpReg src) (OpReg dst)+        RcDouble    ->  MOV FF64 (OpReg src) (OpReg dst)+        -- this code is the lie we tell ourselves because both float and double+        -- use the same register class.on x86_64 and x86 32bit with SSE2,+        -- more plainly, both use the XMM registers         _     -> panic "X86.RegInfo.mkRegRegMoveInstr: no match"  -- | Check whether an instruction represents a reg-reg move.@@ -965,58 +888,6 @@       ArchX86    -> [ADD II32 (OpImm (ImmInt amount)) (OpReg esp)]       ArchX86_64 -> [ADD II64 (OpImm (ImmInt amount)) (OpReg rsp)]       _ -> panic "x86_mkStackDeallocInstr"--i386_insert_ffrees-        :: [GenBasicBlock Instr]-        -> [GenBasicBlock Instr]--i386_insert_ffrees blocks-   | any (any is_G_instr) [ instrs | BasicBlock _ instrs <- blocks ]-   = map insertGFREEs blocks-   | otherwise-   = blocks- where-   insertGFREEs (BasicBlock id insns)-     = BasicBlock id (insertBeforeNonlocalTransfers GFREE insns)--insertBeforeNonlocalTransfers :: Instr -> [Instr] -> [Instr]-insertBeforeNonlocalTransfers insert insns-     = foldr p [] insns-     where p insn r = case insn of-                        CALL _ _    -> insert : insn : r-                        JMP _ _     -> insert : insn : r-                        JXX_GBL _ _ -> panic "insertBeforeNonlocalTransfers: cannot handle JXX_GBL"-                        _           -> insn : r----- if you ever add a new FP insn to the fake x86 FP insn set,--- you must update this too-is_G_instr :: Instr -> Bool-is_G_instr instr-   = case instr of-        GMOV{}          -> True-        GLD{}           -> True-        GST{}           -> True-        GLDZ{}          -> True-        GLD1{}          -> True-        GFTOI{}         -> True-        GDTOI{}         -> True-        GITOF{}         -> True-        GITOD{}         -> True-        GDTOF{}         -> True-        GADD{}          -> True-        GDIV{}          -> True-        GSUB{}          -> True-        GMUL{}          -> True-        GCMP{}          -> True-        GABS{}          -> True-        GNEG{}          -> True-        GSQRT{}         -> True-        GSIN{}          -> True-        GCOS{}          -> True-        GTAN{}          -> True-        GFREE           -> panic "is_G_instr: GFREE (!)"-        _               -> False   --
compiler/nativeGen/X86/Ppr.hs view
@@ -20,8 +20,7 @@  where -#include "GhclibHsVersions.h"-#include "nativeGen/NCG.h"+#include "HsVersions.h"  import GhcPrelude @@ -36,18 +35,17 @@  import Hoopl.Collections import Hoopl.Label-import BasicTypes       (Alignment)+import BasicTypes       (Alignment, mkAlignment, alignmentBytes) import DynFlags import Cmm              hiding (topInfoTable) import BlockId import CLabel import Unique           ( pprUniqueAlways )-import Platform+import GHC.Platform import FastString import Outputable  import Data.Word- import Data.Bits  -- -----------------------------------------------------------------------------@@ -73,7 +71,7 @@  pprProcAlignment :: SDoc pprProcAlignment = sdocWithDynFlags $ \dflags ->-  (maybe empty pprAlign . cmmProcAlignment $ dflags)+  (maybe empty (pprAlign . mkAlignment) (cmmProcAlignment dflags))  pprNatCmmDecl :: NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc pprNatCmmDecl (CmmData section dats) =@@ -84,17 +82,14 @@   pprProcAlignment $$   case topInfoTable proc of     Nothing ->-       case blocks of-         []     -> -- special case for split markers:-           pprLabel lbl-         blocks -> -- special case for code without info table:-           pprSectionAlign (Section Text lbl) $$-           pprProcAlignment $$-           pprLabel lbl $$ -- blocks guaranteed not null, so label needed-           vcat (map (pprBasicBlock top_info) blocks) $$-           (if debugLevel dflags > 0-            then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$-           pprSizeDecl lbl+        -- special case for code without info table:+        pprSectionAlign (Section Text lbl) $$+        pprProcAlignment $$+        pprLabel lbl $$ -- blocks guaranteed not null, so label needed+        vcat (map (pprBasicBlock top_info) blocks) $$+        (if debugLevel dflags > 0+         then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$+        pprSizeDecl lbl      Just (Statics info_lbl _) ->       sdocWithPlatform $ \platform ->@@ -149,13 +144,24 @@       (l@LOCATION{} : _) -> pprInstr l       _other             -> empty + pprDatas :: (Alignment, CmmStatics) -> SDoc+-- See note [emit-time elimination of static indirections] in CLabel.+pprDatas (_, Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])+  | lbl == mkIndStaticInfoLabel+  , let labelInd (CmmLabelOff l _) = Just l+        labelInd (CmmLabel l) = Just l+        labelInd _ = Nothing+  , Just ind' <- labelInd ind+  , alias `mayRedirectTo` ind'+  = pprGloblDecl alias+    $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')+ pprDatas (align, (Statics lbl dats))  = vcat (pprAlign align : pprLabel lbl : map pprData dats)  pprData :: CmmStatic -> SDoc-pprData (CmmString str)- = ptext (sLit "\t.asciz ") <> doubleQuotes (pprASCII str)+pprData (CmmString str) = pprBytes str  pprData (CmmUninitialised bytes)  = sdocWithPlatform $ \platform ->@@ -217,7 +223,7 @@     "      A good place to check for more-    https://ghc.haskell.org/trac/ghc/wiki/Commentary/PositionIndependentCode+    https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code      Another possible hack is to create an extra local function symbol for     every code-like thing to give the needed information for to the tools@@ -241,14 +247,15 @@             $$ pprTypeDecl lbl             $$ (ppr lbl <> char ':') -pprAlign :: Int -> SDoc-pprAlign bytes+pprAlign :: Alignment -> SDoc+pprAlign alignment         = sdocWithPlatform $ \platform ->-          text ".align " <> int (alignment platform)+          text ".align " <> int (alignmentOn platform)   where-        alignment platform = if platformOS platform == OSDarwin-                             then log2 bytes-                             else      bytes+        bytes = alignmentBytes alignment+        alignmentOn platform = if platformOS platform == OSDarwin+                               then log2 bytes+                               else      bytes          log2 :: Int -> Int  -- cache the common ones         log2 1 = 0@@ -276,7 +283,7 @@       RegVirtual (VirtualRegHi u)  -> text "%vHi_"  <> pprUniqueAlways u       RegVirtual (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u       RegVirtual (VirtualRegD  u)  -> text "%vD_"   <> pprUniqueAlways u-      RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> pprUniqueAlways u+   where     ppr32_reg_no :: Format -> Int -> SDoc     ppr32_reg_no II8   = ppr32_reg_byte@@ -368,17 +375,14 @@  ppr_reg_float :: Int -> PtrString ppr_reg_float i = case i of-        16 -> sLit "%fake0";  17 -> sLit "%fake1"-        18 -> sLit "%fake2";  19 -> sLit "%fake3"-        20 -> sLit "%fake4";  21 -> sLit "%fake5"-        24 -> sLit "%xmm0";   25 -> sLit "%xmm1"-        26 -> sLit "%xmm2";   27 -> sLit "%xmm3"-        28 -> sLit "%xmm4";   29 -> sLit "%xmm5"-        30 -> sLit "%xmm6";   31 -> sLit "%xmm7"-        32 -> sLit "%xmm8";   33 -> sLit "%xmm9"-        34 -> sLit "%xmm10";  35 -> sLit "%xmm11"-        36 -> sLit "%xmm12";  37 -> sLit "%xmm13"-        38 -> sLit "%xmm14";  39 -> sLit "%xmm15"+        16 -> sLit "%xmm0" ;   17 -> sLit "%xmm1"+        18 -> sLit "%xmm2" ;   19 -> sLit "%xmm3"+        20 -> sLit "%xmm4" ;   21 -> sLit "%xmm5"+        22 -> sLit "%xmm6" ;   23 -> sLit "%xmm7"+        24 -> sLit "%xmm8" ;   25 -> sLit "%xmm9"+        26 -> sLit "%xmm10";   27 -> sLit "%xmm11"+        28 -> sLit "%xmm12";   29 -> sLit "%xmm13"+        30 -> sLit "%xmm14";   31 -> sLit "%xmm15"         _  -> sLit "very naughty x86 register"  pprFormat :: Format -> SDoc@@ -390,7 +394,6 @@                 II64  -> sLit "q"                 FF32  -> sLit "ss"      -- "scalar single-precision float" (SSE2)                 FF64  -> sLit "sd"      -- "scalar double-precision float" (SSE2)-                FF80  -> sLit "t"                 )  pprFormat_x87 :: Format -> SDoc@@ -398,9 +401,9 @@   = ptext $ case x of                 FF32  -> sLit "s"                 FF64  -> sLit "l"-                FF80  -> sLit "t"                 _     -> panic "X86.Ppr.pprFormat_x87" + pprCond :: Cond -> SDoc pprCond c  = ptext (case c of {@@ -693,6 +696,8 @@ pprInstr (XOR format src dst) = pprFormatOpOp (sLit "xor")  format src dst  pprInstr (POPCNT format src dst) = pprOpOp (sLit "popcnt") format src (OpReg dst)+pprInstr (LZCNT format src dst)  = pprOpOp (sLit "lzcnt")  format src (OpReg dst)+pprInstr (TZCNT format src dst)  = pprOpOp (sLit "tzcnt")  format src (OpReg dst) pprInstr (BSF format src dst)    = pprOpOp (sLit "bsf")    format src (OpReg dst) pprInstr (BSR format src dst)    = pprOpOp (sLit "bsr")    format src (OpReg dst) @@ -729,7 +734,7 @@         -- The mask must have the high bit clear for this smaller encoding         -- to be completely equivalent to the original; in particular so         -- that the signed comparison condition bits are the same as they-        -- would be if doing a full word comparison. See Trac #13425.+        -- would be if doing a full word comparison. See #13425.         (OpImm (ImmInteger mask), OpReg dstReg)           | 0 <= mask && mask < 128 -> minSizeOfReg platform dstReg         _ -> format@@ -809,225 +814,13 @@           ]  --- -------------------------------------------------------------------------------- i386 floating-point---- Simulating a flat register set on the x86 FP stack is tricky.--- you have to free %st(7) before pushing anything on the FP reg stack--- so as to preclude the possibility of a FP stack overflow exception.-pprInstr g@(GMOV src dst)-   | src == dst-   = empty-   | otherwise-   = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])---- GLD fmt addr dst ==> FLDsz addr ; FSTP (dst+1)-pprInstr g@(GLD fmt addr dst)- = pprG g (hcat [gtab, text "fld", pprFormat_x87 fmt, gsp,-                 pprAddr addr, gsemi, gpop dst 1])-+-- the -- GST fmt src addr ==> FLD dst ; FSTPsz addr-pprInstr g@(GST fmt src addr)- | src == fake0 && fmt /= FF80 -- fstt instruction doesn't exist- = pprG g (hcat [gtab,-                 text "fst", pprFormat_x87 fmt, gsp, pprAddr addr])- | otherwise- = pprG g (hcat [gtab, gpush src 0, gsemi,+pprInstr g@(X87Store fmt  addr)+ = pprX87 g (hcat [gtab,                  text "fstp", pprFormat_x87 fmt, gsp, pprAddr addr]) -pprInstr g@(GLDZ dst)- = pprG g (hcat [gtab, text "fldz ; ", gpop dst 1])-pprInstr g@(GLD1 dst)- = pprG g (hcat [gtab, text "fld1 ; ", gpop dst 1]) -pprInstr (GFTOI src dst)-   = pprInstr (GDTOI src dst)--pprInstr g@(GDTOI src dst)-   = pprG g (vcat [-         hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"],-         hcat [gtab, gpush src 0],-         hcat [gtab, text "movzwl 4(%esp), ", reg,-                     text " ; orl $0xC00, ", reg],-         hcat [gtab, text "movl ", reg, text ", 0(%esp) ; fldcw 0(%esp)"],-         hcat [gtab, text "fistpl 0(%esp)"],-         hcat [gtab, text "fldcw 4(%esp) ; movl 0(%esp), ", reg],-         hcat [gtab, text "addl $8, %esp"]-     ])-   where-     reg = pprReg II32 dst--pprInstr (GITOF src dst)-   = pprInstr (GITOD src dst)--pprInstr g@(GITOD src dst)-   = pprG g (hcat [gtab, text "pushl ", pprReg II32 src,-                   text " ; fildl (%esp) ; ",-                   gpop dst 1, text " ; addl $4,%esp"])--pprInstr g@(GDTOF src dst)-  = pprG g (vcat [gtab <> gpush src 0,-                  gtab <> text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ;",-                  gtab <> gpop dst 1])--{- Gruesome swamp follows.  If you're unfortunate enough to have ventured-   this far into the jungle AND you give a Rat's Ass (tm) what's going-   on, here's the deal.  Generate code to do a floating point comparison-   of src1 and src2, of kind cond, and set the Zero flag if true.--   The complications are to do with handling NaNs correctly.  We want the-   property that if either argument is NaN, then the result of the-   comparison is False ... except if we're comparing for inequality,-   in which case the answer is True.--   Here's how the general (non-inequality) case works.  As an-   example, consider generating the an equality test:--     pushl %eax         -- we need to mess with this-     <get src1 to top of FPU stack>-     fcomp <src2 location in FPU stack> and pop pushed src1-                -- Result of comparison is in FPU Status Register bits-                -- C3 C2 and C0-     fstsw %ax  -- Move FPU Status Reg to %ax-     sahf       -- move C3 C2 C0 from %ax to integer flag reg-     -- now the serious magic begins-     setpo %ah     -- %ah = if comparable(neither arg was NaN) then 1 else 0-     sete  %al     -- %al = if arg1 == arg2 then 1 else 0-     andb %ah,%al  -- %al &= %ah-                   -- so %al == 1 iff (comparable && same); else it holds 0-     decb %al      -- %al == 0, ZeroFlag=1  iff (comparable && same);-                      else %al == 0xFF, ZeroFlag=0-     -- the zero flag is now set as we desire.-     popl %eax--   The special case of inequality differs thusly:--     setpe %ah     -- %ah = if incomparable(either arg was NaN) then 1 else 0-     setne %al     -- %al = if arg1 /= arg2 then 1 else 0-     orb %ah,%al   -- %al = if (incomparable || different) then 1 else 0-     decb %al      -- if (incomparable || different) then (%al == 0, ZF=1)-                                                     else (%al == 0xFF, ZF=0)--}-pprInstr g@(GCMP cond src1 src2)-   | case cond of { NE -> True; _ -> False }-   = pprG g (vcat [-        hcat [gtab, text "pushl %eax ; ",gpush src1 0],-        hcat [gtab, text "fcomp ", greg src2 1,-                    text "; fstsw %ax ; sahf ;  setpe %ah"],-        hcat [gtab, text "setne %al ;  ",-              text "orb %ah,%al ;  decb %al ;  popl %eax"]-    ])-   | otherwise-   = pprG g (vcat [-        hcat [gtab, text "pushl %eax ; ",gpush src1 0],-        hcat [gtab, text "fcomp ", greg src2 1,-                    text "; fstsw %ax ; sahf ;  setpo %ah"],-        hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ;  ",-              text "andb %ah,%al ;  decb %al ;  popl %eax"]-    ])-    where-        {- On the 486, the flags set by FP compare are the unsigned ones!-           (This looks like a HACK to me.  WDP 96/03)-        -}-        fix_FP_cond :: Cond -> Cond-        fix_FP_cond GE   = GEU-        fix_FP_cond GTT  = GU-        fix_FP_cond LTT  = LU-        fix_FP_cond LE   = LEU-        fix_FP_cond EQQ  = EQQ-        fix_FP_cond NE   = NE-        fix_FP_cond _    = panic "X86.Ppr.fix_FP_cond: no match"-        -- there should be no others---pprInstr g@(GABS _ src dst)-   = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])--pprInstr g@(GNEG _ src dst)-   = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])--pprInstr g@(GSQRT fmt src dst)-   = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$-             hcat [gtab, gcoerceto fmt, gpop dst 1])--pprInstr g@(GSIN fmt l1 l2 src dst)-   = pprG g (pprTrigOp "fsin" False l1 l2 src dst fmt)--pprInstr g@(GCOS fmt l1 l2 src dst)-   = pprG g (pprTrigOp "fcos" False l1 l2 src dst fmt)--pprInstr g@(GTAN fmt l1 l2 src dst)-   = pprG g (pprTrigOp "fptan" True l1 l2 src dst fmt)---- In the translations for GADD, GMUL, GSUB and GDIV,--- the first two cases are mere optimisations.  The otherwise clause--- generates correct code under all circumstances.--pprInstr g@(GADD _ src1 src2 dst)-   | src1 == dst-   = pprG g (text "\t#GADD-xxxcase1" $$-             hcat [gtab, gpush src2 0,-                   text " ; faddp %st(0),", greg src1 1])-   | src2 == dst-   = pprG g (text "\t#GADD-xxxcase2" $$-             hcat [gtab, gpush src1 0,-                   text " ; faddp %st(0),", greg src2 1])-   | otherwise-   = pprG g (hcat [gtab, gpush src1 0,-                   text " ; fadd ", greg src2 1, text ",%st(0)",-                   gsemi, gpop dst 1])---pprInstr g@(GMUL _ src1 src2 dst)-   | src1 == dst-   = pprG g (text "\t#GMUL-xxxcase1" $$-             hcat [gtab, gpush src2 0,-                   text " ; fmulp %st(0),", greg src1 1])-   | src2 == dst-   = pprG g (text "\t#GMUL-xxxcase2" $$-             hcat [gtab, gpush src1 0,-                   text " ; fmulp %st(0),", greg src2 1])-   | otherwise-   = pprG g (hcat [gtab, gpush src1 0,-             text " ; fmul ", greg src2 1, text ",%st(0)",-             gsemi, gpop dst 1])---pprInstr g@(GSUB _ src1 src2 dst)-   | src1 == dst-   = pprG g (text "\t#GSUB-xxxcase1" $$-             hcat [gtab, gpush src2 0,-                   text " ; fsubrp %st(0),", greg src1 1])-   | src2 == dst-   = pprG g (text "\t#GSUB-xxxcase2" $$-             hcat [gtab, gpush src1 0,-                   text " ; fsubp %st(0),", greg src2 1])-   | otherwise-   = pprG g (hcat [gtab, gpush src1 0,-                   text " ; fsub ", greg src2 1, text ",%st(0)",-                   gsemi, gpop dst 1])---pprInstr g@(GDIV _ src1 src2 dst)-   | src1 == dst-   = pprG g (text "\t#GDIV-xxxcase1" $$-             hcat [gtab, gpush src2 0,-                   text " ; fdivrp %st(0),", greg src1 1])-   | src2 == dst-   = pprG g (text "\t#GDIV-xxxcase2" $$-             hcat [gtab, gpush src1 0,-                   text " ; fdivp %st(0),", greg src2 1])-   | otherwise-   = pprG g (hcat [gtab, gpush src1 0,-                   text " ; fdiv ", greg src2 1, text ",%st(0)",-                   gsemi, gpop dst 1])---pprInstr GFREE-   = vcat [ text "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)",-            text "\tffree %st(4) ;ffree %st(5)"-          ]- -- Atomics  pprInstr (LOCK i) = text "\tlock" $$ pprInstr i@@ -1040,116 +833,27 @@    = pprFormatOpOp (sLit "cmpxchg") format src dst  -pprTrigOp :: String -> Bool -> CLabel -> CLabel-          -> Reg -> Reg -> Format -> SDoc-pprTrigOp op -- fsin, fcos or fptan-          isTan -- we need a couple of extra steps if we're doing tan-          l1 l2 -- internal labels for us to use-          src dst fmt-    = -- We'll be needing %eax later on-      hcat [gtab, text "pushl %eax;"] $$-      -- tan is going to use an extra space on the FP stack-      (if isTan then hcat [gtab, text "ffree %st(6)"] else empty) $$-      -- First put the value in %st(0) and try to apply the op to it-      hcat [gpush src 0, text ("; " ++ op)] $$-      -- Now look to see if C2 was set (overflow, |value| >= 2^63)-      hcat [gtab, text "fnstsw %ax"] $$-      hcat [gtab, text "test   $0x400,%eax"] $$-      -- If we were in bounds then jump to the end-      hcat [gtab, text "je     " <> ppr l1] $$-      -- Otherwise we need to shrink the value. Start by-      -- loading pi, doubleing it (by adding it to itself),-      -- and then swapping pi with the value, so the value we-      -- want to apply op to is in %st(0) again-      hcat [gtab, text "ffree %st(7); fldpi"] $$-      hcat [gtab, text "fadd   %st(0),%st"] $$-      hcat [gtab, text "fxch   %st(1)"] $$-      -- Now we have a loop in which we make the value smaller,-      -- see if it's small enough, and loop if not-      (ppr l2 <> char ':') $$-      hcat [gtab, text "fprem1"] $$-      -- My Debian libc uses fstsw here for the tan code, but I can't-      -- see any reason why it should need to be different for tan.-      hcat [gtab, text "fnstsw %ax"] $$-      hcat [gtab, text "test   $0x400,%eax"] $$-      hcat [gtab, text "jne    " <> ppr l2] $$-      hcat [gtab, text "fstp   %st(1)"] $$-      hcat [gtab, text op] $$-      (ppr l1 <> char ':') $$-      -- Pop the 1.0 tan gave us-      (if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$-      -- Restore %eax-      hcat [gtab, text "popl %eax;"] $$-      -- And finally make the result the right size-      hcat [gtab, gcoerceto fmt, gpop dst 1]  --------------------------+-- some left over --- coerce %st(0) to the specified size-gcoerceto :: Format -> SDoc-gcoerceto FF64 = empty-gcoerceto FF32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "-gcoerceto _    = panic "X86.Ppr.gcoerceto: no match" -gpush :: Reg -> RegNo -> SDoc-gpush reg offset-   = hcat [text "fld ", greg reg offset] -gpop :: Reg -> RegNo -> SDoc-gpop reg offset-   = hcat [text "fstp ", greg reg offset]--greg :: Reg -> RegNo -> SDoc-greg reg offset = text "%st(" <> int (gregno reg - firstfake+offset) <> char ')'--gsemi :: SDoc-gsemi = text " ; "- gtab :: SDoc gtab  = char '\t'  gsp :: SDoc gsp   = char ' ' -gregno :: Reg -> RegNo-gregno (RegReal (RealRegSingle i)) = i-gregno _           = --pprPanic "gregno" (ppr other)-                     999   -- bogus; only needed for debug printing -pprG :: Instr -> SDoc -> SDoc-pprG fake actual-   = (char '#' <> pprGInstr fake) $$ actual --pprGInstr :: Instr -> SDoc-pprGInstr (GMOV src dst)   = pprFormatRegReg (sLit "gmov") FF64 src dst-pprGInstr (GLD fmt src dst) = pprFormatAddrReg (sLit "gld") fmt src dst-pprGInstr (GST fmt src dst) = pprFormatRegAddr (sLit "gst") fmt src dst--pprGInstr (GLDZ dst) = pprFormatReg (sLit "gldz") FF64 dst-pprGInstr (GLD1 dst) = pprFormatReg (sLit "gld1") FF64 dst--pprGInstr (GFTOI src dst) = pprFormatFormatRegReg (sLit "gftoi") FF32 II32 src dst-pprGInstr (GDTOI src dst) = pprFormatFormatRegReg (sLit "gdtoi") FF64 II32 src dst--pprGInstr (GITOF src dst) = pprFormatFormatRegReg (sLit "gitof") II32 FF32 src dst-pprGInstr (GITOD src dst) = pprFormatFormatRegReg (sLit "gitod") II32 FF64 src dst-pprGInstr (GDTOF src dst) = pprFormatFormatRegReg (sLit "gdtof") FF64 FF32 src dst--pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst-pprGInstr (GABS fmt src dst) = pprFormatRegReg (sLit "gabs") fmt src dst-pprGInstr (GNEG fmt src dst) = pprFormatRegReg (sLit "gneg") fmt src dst-pprGInstr (GSQRT fmt src dst) = pprFormatRegReg (sLit "gsqrt") fmt src dst-pprGInstr (GSIN fmt _ _ src dst) = pprFormatRegReg (sLit "gsin") fmt src dst-pprGInstr (GCOS fmt _ _ src dst) = pprFormatRegReg (sLit "gcos") fmt src dst-pprGInstr (GTAN fmt _ _ src dst) = pprFormatRegReg (sLit "gtan") fmt src dst--pprGInstr (GADD fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gadd") fmt src1 src2 dst-pprGInstr (GSUB fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gsub") fmt src1 src2 dst-pprGInstr (GMUL fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gmul") fmt src1 src2 dst-pprGInstr (GDIV fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gdiv") fmt src1 src2 dst+pprX87 :: Instr -> SDoc -> SDoc+pprX87 fake actual+   = (char '#' <> pprX87Instr fake) $$ actual -pprGInstr _ = panic "X86.Ppr.pprGInstr: no match"+pprX87Instr :: Instr -> SDoc+pprX87Instr (X87Store fmt  dst) = pprFormatAddr (sLit "gst") fmt  dst+pprX87Instr _ = panic "X86.Ppr.pprX87Instr: no match"  pprDollImm :: Imm -> SDoc pprDollImm i = text "$" <> pprImm i@@ -1217,24 +921,7 @@     ]  -pprFormatReg :: PtrString -> Format -> Reg -> SDoc-pprFormatReg name format reg1-  = hcat [-        pprMnemonic name format,-        pprReg format reg1-    ] --pprFormatRegReg :: PtrString -> Format -> Reg -> Reg -> SDoc-pprFormatRegReg name format reg1 reg2-  = hcat [-        pprMnemonic name format,-        pprReg format reg1,-        comma,-        pprReg format reg2-    ]-- pprRegReg :: PtrString -> Reg -> Reg -> SDoc pprRegReg name reg1 reg2   = sdocWithPlatform $ \platform ->@@ -1268,31 +955,6 @@         pprReg format reg2     ] -pprCondRegReg :: PtrString -> Format -> Cond -> Reg -> Reg -> SDoc-pprCondRegReg name format cond reg1 reg2-  = hcat [-        char '\t',-        ptext name,-        pprCond cond,-        space,-        pprReg format reg1,-        comma,-        pprReg format reg2-    ]--pprFormatFormatRegReg :: PtrString -> Format -> Format -> Reg -> Reg -> SDoc-pprFormatFormatRegReg name format1 format2 reg1 reg2-  = hcat [-        char '\t',-        ptext name,-        pprFormat format1,-        pprFormat format2,-        space,-        pprReg format1 reg1,-        comma,-        pprReg format2 reg2-    ]- pprFormatFormatOpReg :: PtrString -> Format -> Format -> Operand -> Reg -> SDoc pprFormatFormatOpReg name format1 format2 op1 reg2   = hcat [@@ -1302,17 +964,6 @@         pprReg format2 reg2     ] -pprFormatRegRegReg :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc-pprFormatRegRegReg name format reg1 reg2 reg3-  = hcat [-        pprMnemonic name format,-        pprReg format reg1,-        comma,-        pprReg format reg2,-        comma,-        pprReg format reg3-    ]- pprFormatOpOpReg :: PtrString -> Format -> Operand -> Operand -> Reg -> SDoc pprFormatOpOpReg name format op1 op2 reg3   = hcat [@@ -1324,25 +975,15 @@         pprReg format reg3     ] -pprFormatAddrReg :: PtrString -> Format -> AddrMode -> Reg -> SDoc-pprFormatAddrReg name format op dst-  = hcat [-        pprMnemonic name format,-        pprAddr op,-        comma,-        pprReg format dst-    ]  -pprFormatRegAddr :: PtrString -> Format -> Reg -> AddrMode -> SDoc-pprFormatRegAddr name format src op+pprFormatAddr :: PtrString -> Format -> AddrMode -> SDoc+pprFormatAddr name format  op   = hcat [         pprMnemonic name format,-        pprReg format src,         comma,         pprAddr op     ]-  pprShift :: PtrString -> Format -> Operand -> Operand -> SDoc pprShift name format src dest
compiler/nativeGen/X86/RegInfo.hs view
@@ -6,8 +6,7 @@  where -#include "nativeGen/NCG.h"-#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -15,7 +14,7 @@ import Reg  import Outputable-import Platform+import GHC.Platform import Unique  import UniqFM@@ -25,45 +24,50 @@ mkVirtualReg :: Unique -> Format -> VirtualReg mkVirtualReg u format    = case format of-        FF32    -> VirtualRegSSE u-        FF64    -> VirtualRegSSE u-        FF80    -> VirtualRegD   u-        _other  -> VirtualRegI   u+        FF32    -> VirtualRegD u+        -- for scalar F32, we use the same xmm as F64!+        -- this is a hack that needs some improvement.+        -- For now we map both to being allocated as "Double" Registers+        -- on X86/X86_64+        FF64    -> VirtualRegD u+        _other  -> VirtualRegI u  regDotColor :: Platform -> RealReg -> SDoc regDotColor platform reg- = let Just str = lookupUFM (regColors platform) reg-   in text str+ = case (lookupUFM (regColors platform) reg) of+        Just str -> text str+        _        -> panic "Register not assigned a color"  regColors :: Platform -> UniqFM [Char]-regColors platform = listToUFM (normalRegColors platform ++ fpRegColors)+regColors platform = listToUFM (normalRegColors platform)  normalRegColors :: Platform -> [(Reg,String)]-normalRegColors platform- | target32Bit platform = [ (eax, "#00ff00")-                          , (ebx, "#0000ff")-                          , (ecx, "#00ffff")-                          , (edx, "#0080ff") ]- | otherwise            = [ (rax, "#00ff00"), (eax, "#00ff00")-                          , (rbx, "#0000ff"), (ebx, "#0000ff")-                          , (rcx, "#00ffff"), (ecx, "#00ffff")-                          , (rdx, "#0080ff"), (edx, "#00ffff")-                          , (r8,  "#00ff80")-                          , (r9,  "#008080")-                          , (r10, "#0040ff")-                          , (r11, "#00ff40")-                          , (r12, "#008040")-                          , (r13, "#004080")-                          , (r14, "#004040")-                          , (r15, "#002080") ]+normalRegColors platform =+    zip (map regSingle [0..lastint platform]) colors+        ++ zip (map regSingle [firstxmm..lastxmm platform]) greys+  where+    -- 16 colors - enough for amd64 gp regs+    colors = ["#800000","#ff0000","#808000","#ffff00","#008000"+             ,"#00ff00","#008080","#00ffff","#000080","#0000ff"+             ,"#800080","#ff00ff","#87005f","#875f00","#87af00"+             ,"#ff00af"] -fpRegColors :: [(Reg,String)]-fpRegColors =-        [ (fake0, "#ff00ff")-        , (fake1, "#ff00aa")-        , (fake2, "#aa00ff")-        , (fake3, "#aa00aa")-        , (fake4, "#ff0055")-        , (fake5, "#5500ff") ]+    -- 16 shades of grey, enough for the currently supported+    -- SSE extensions.+    greys = ["#0e0e0e","#1c1c1c","#2a2a2a","#383838","#464646"+            ,"#545454","#626262","#707070","#7e7e7e","#8c8c8c"+            ,"#9a9a9a","#a8a8a8","#b6b6b6","#c4c4c4","#d2d2d2"+            ,"#e0e0e0"] -        ++ zip (map regSingle [24..39]) (repeat "red")+++--     32 shades of grey - use for avx 512 if we ever need it+--     greys = ["#070707","#0e0e0e","#151515","#1c1c1c"+--             ,"#232323","#2a2a2a","#313131","#383838","#3f3f3f"+--             ,"#464646","#4d4d4d","#545454","#5b5b5b","#626262"+--             ,"#696969","#707070","#777777","#7e7e7e","#858585"+--             ,"#8c8c8c","#939393","#9a9a9a","#a1a1a1","#a8a8a8"+--             ,"#afafaf","#b6b6b6","#bdbdbd","#c4c4c4","#cbcbcb"+--             ,"#d2d2d2","#d9d9d9","#e0e0e0"]++
compiler/nativeGen/X86/Regs.hs view
@@ -29,13 +29,15 @@         EABase(..), EAIndex(..), addrModeRegs,          eax, ebx, ecx, edx, esi, edi, ebp, esp,-        fake0, fake1, fake2, fake3, fake4, fake5, firstfake, +         rax, rbx, rcx, rdx, rsi, rdi, rbp, rsp,         r8,  r9,  r10, r11, r12, r13, r14, r15,+        lastint,         xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7,         xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15,         xmm,+        firstxmm, lastxmm,          ripRel,         allFPArgRegs,@@ -45,12 +47,11 @@  where -#include "nativeGen/NCG.h"-#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude -import CodeGen.Platform+import GHC.Platform.Regs import Reg import RegClass @@ -58,7 +59,7 @@ import CLabel           ( CLabel ) import DynFlags import Outputable-import Platform+import GHC.Platform  import qualified Data.Array as A @@ -84,10 +85,6 @@                 VirtualRegF{}           -> 0                 _other                  -> 0 -        RcDoubleSSE-         -> case vr of-                VirtualRegSSE{}         -> 1-                _other                  -> 0          _other -> 0 @@ -98,7 +95,7 @@         RcInteger          -> case rr of                 RealRegSingle regNo-                        | regNo < firstfake -> 1+                        | regNo < firstxmm -> 1                         | otherwise     -> 0                  RealRegPair{}           -> 0@@ -106,15 +103,11 @@         RcDouble          -> case rr of                 RealRegSingle regNo-                        | regNo >= firstfake && regNo <= lastfake -> 1+                        | regNo >= firstxmm  -> 1                         | otherwise     -> 0                  RealRegPair{}           -> 0 -        RcDoubleSSE-         -> case rr of-                RealRegSingle regNo | regNo >= firstxmm -> 1-                _otherwise                        -> 0          _other -> 0 @@ -208,17 +201,16 @@ -- use a Word32 to represent the set of free registers in the register -- allocator. -firstfake, lastfake :: RegNo-firstfake = 16-lastfake  = 21 + firstxmm :: RegNo-firstxmm  = 24+firstxmm  = 16 +--  on 32bit platformOSs, only the first 8 XMM/YMM/ZMM registers are available lastxmm :: Platform -> RegNo lastxmm platform- | target32Bit platform = 31- | otherwise            = 39+ | target32Bit platform = firstxmm + 7  -- xmm0 - xmmm7+ | otherwise            = firstxmm + 15 -- xmm0 -xmm15  lastint :: Platform -> RegNo lastint platform@@ -228,14 +220,13 @@ intregnos :: Platform -> [RegNo] intregnos platform = [0 .. lastint platform] -fakeregnos :: [RegNo]-fakeregnos  = [firstfake .. lastfake] + xmmregnos :: Platform -> [RegNo] xmmregnos platform = [firstxmm  .. lastxmm platform]  floatregnos :: Platform -> [RegNo]-floatregnos platform = fakeregnos ++ xmmregnos platform+floatregnos platform = xmmregnos platform  -- argRegs is the set of regs which are read for an n-argument call to C. -- For archs which pass all args on the stack (x86), is empty.@@ -255,20 +246,19 @@ -- However, we can get away without this at the moment because the -- only allocatable integer regs are also 8-bit compatible (1, 3, 4). classOfRealReg platform reg- = case reg of+    = case reg of         RealRegSingle i-          | i <= lastint platform -> RcInteger-          | i <= lastfake         -> RcDouble-          | otherwise             -> RcDoubleSSE--        RealRegPair{}   -> panic "X86.Regs.classOfRealReg: RegPairs on this arch"+            | i <= lastint platform -> RcInteger+            | i <= lastxmm platform -> RcDouble+            | otherwise             -> panic "X86.Reg.classOfRealReg registerSingle too high"+        _   -> panic "X86.Regs.classOfRealReg: RegPairs on this arch"  -- | Get the name of the register with this number.+-- NOTE: fixme, we dont track which "way" the XMM registers are used showReg :: Platform -> RegNo -> String showReg platform n-        | n >= firstxmm  = "%xmm" ++ show (n-firstxmm)-        | n >= firstfake = "%fake" ++ show (n-firstfake)-        | n >= 8         = "%r" ++ show n+        | n >= firstxmm && n <= lastxmm  platform = "%xmm" ++ show (n-firstxmm)+        | n >= 8   && n < firstxmm      = "%r" ++ show n         | otherwise      = regNames platform A.! n  regNames :: Platform -> A.Array Int String@@ -288,18 +278,17 @@ - Only ebx, esi, edi and esp are available across a C call (they are callee-saves). - Registers 0-7 have 16-bit counterparts (ax, bx etc.) - Registers 0-3 have 8 bit counterparts (ah, bh etc.)-- Registers fake0..fake5 are fakes; we pretend x86 has 6 conventionally-addressable-  fp registers, and 3-operand insns for them, and we translate this into-  real stack-based x86 fp code after register allocation.  The fp registers are all Double registers; we don't have any RcFloat class regs.  @regClass@ barfs if you give it a VirtualRegF, and mkVReg above should never generate them.++TODO: cleanup modelling float vs double registers and how they are the same class. -} -fake0, fake1, fake2, fake3, fake4, fake5,-       eax, ebx, ecx, edx, esp, ebp, esi, edi :: Reg +eax, ebx, ecx, edx, esp, ebp, esi, edi :: Reg+ eax   = regSingle 0 ebx   = regSingle 1 ecx   = regSingle 2@@ -308,15 +297,10 @@ edi   = regSingle 5 ebp   = regSingle 6 esp   = regSingle 7-fake0 = regSingle 16-fake1 = regSingle 17-fake2 = regSingle 18-fake3 = regSingle 19-fake4 = regSingle 20-fake5 = regSingle 21   + {- AMD x86_64 architecture: - All 16 integer registers are addressable as 8, 16, 32 and 64-bit values:@@ -360,22 +344,22 @@ r13   = regSingle 13 r14   = regSingle 14 r15   = regSingle 15-xmm0  = regSingle 24-xmm1  = regSingle 25-xmm2  = regSingle 26-xmm3  = regSingle 27-xmm4  = regSingle 28-xmm5  = regSingle 29-xmm6  = regSingle 30-xmm7  = regSingle 31-xmm8  = regSingle 32-xmm9  = regSingle 33-xmm10 = regSingle 34-xmm11 = regSingle 35-xmm12 = regSingle 36-xmm13 = regSingle 37-xmm14 = regSingle 38-xmm15 = regSingle 39+xmm0  = regSingle 16+xmm1  = regSingle 17+xmm2  = regSingle 18+xmm3  = regSingle 19+xmm4  = regSingle 20+xmm5  = regSingle 21+xmm6  = regSingle 22+xmm7  = regSingle 23+xmm8  = regSingle 24+xmm9  = regSingle 25+xmm10 = regSingle 26+xmm11 = regSingle 27+xmm12 = regSingle 28+xmm13 = regSingle 29+xmm14 = regSingle 30+xmm15 = regSingle 31  ripRel :: Displacement -> AddrMode ripRel imm      = AddrBaseIndex EABaseRip EAIndexNone imm@@ -409,7 +393,7 @@    -- Only xmm0-5 are caller-saves registers on 64bit windows.    -- ( https://docs.microsoft.com/en-us/cpp/build/register-usage )    -- For details check the Win64 ABI.-   ++ map regSingle fakeregnos ++ map xmm [0  .. 5]+   ++ map xmm [0  .. 5]  | otherwise     -- all xmm regs are caller-saves     -- caller-saves registers@@ -428,11 +412,15 @@     = panic "X86.Regs.allIntArgRegs: not defined for this platform"  | otherwise = [rdi,rsi,rdx,rcx,r8,r9] ++-- | on 64bit platforms we pass the first 8 float/double arguments+-- in the xmm registers. allFPArgRegs :: Platform -> [Reg] allFPArgRegs platform  | platformOS platform == OSMinGW32     = panic "X86.Regs.allFPArgRegs: not defined for this platform"- | otherwise = map regSingle [firstxmm .. firstxmm+7]+ | otherwise = map regSingle [firstxmm .. firstxmm + 7 ]+  -- Machine registers which might be clobbered by instructions that -- generate results into fixed registers, or need arguments in a fixed
compiler/prelude/PrelInfo.hs view
@@ -44,7 +44,7 @@      ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -215,7 +215,8 @@ knownNamesInfo = unitNameEnv coercibleTyConName $     vcat [ text "Coercible is a special constraint with custom solving rules."          , text "It is not a class."-         , text "Please see section 9.14.4 of the user's guide for details." ]+         , text "Please see section `The Coercible constraint`"+         , text "of the user's guide for details." ]  {- We let a lot of "non-standard" values be visible, so that we can make
compiler/prelude/THNames.hs view
@@ -27,7 +27,7 @@ -- Should stay in sync with the import list of DsMeta  templateHaskellNames = [-    returnQName, bindQName, sequenceQName, newNameName, liftName,+    returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName,     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,     mkNameSName,     liftStringName,@@ -68,7 +68,7 @@     -- Dec     funDName, valDName, dataDName, newtypeDName, tySynDName,     classDName, instanceWithOverlapDName,-    standaloneDerivWithStrategyDName, sigDName, forImpDName,+    standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,     pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,     pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName,     dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,@@ -96,9 +96,9 @@     -- PatSynArgs (for pattern synonyms)     prefixPatSynName, infixPatSynName, recordPatSynName,     -- Type-    forallTName, varTName, conTName, infixTName, appTName, appKindTName,-    equalityTName, tupleTName, unboxedTupleTName, unboxedSumTName,-    arrowTName, listTName, sigTName, litTName,+    forallTName, forallVisTName, varTName, conTName, infixTName, appTName,+    appKindTName, equalityTName, tupleTName, unboxedTupleTName,+    unboxedSumTName, arrowTName, listTName, sigTName, litTName,     promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,     wildCardTName, implicitParamTName,     -- TyLit@@ -206,7 +206,7 @@ returnQName, bindQName, sequenceQName, newNameName, liftName,     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,     mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeQName,-    unsafeTExpCoerceName :: Name+    unsafeTExpCoerceName, liftTypedName :: Name returnQName    = thFun (fsLit "returnQ")   returnQIdKey bindQName      = thFun (fsLit "bindQ")     bindQIdKey sequenceQName  = thFun (fsLit "sequenceQ") sequenceQIdKey@@ -222,6 +222,7 @@ unTypeName     = thFun (fsLit "unType")     unTypeIdKey unTypeQName    = thFun (fsLit "unTypeQ")    unTypeQIdKey unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey+liftTypedName = thFun (fsLit "liftTyped") liftTypedIdKey   -------------------- TH.Lib -----------------------@@ -340,7 +341,7 @@  -- data Dec = ... funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,-    instanceWithOverlapDName, sigDName, forImpDName, pragInlDName,+    instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName,     pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,     pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName,     dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,@@ -356,6 +357,7 @@ instanceWithOverlapDName         = libFun (fsLit "instanceWithOverlapD")         instanceWithOverlapDIdKey standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey sigDName                         = libFun (fsLit "sigD")                         sigDIdKey+kiSigDName                       = libFun (fsLit "kiSigD")                       kiSigDIdKey defaultSigDName                  = libFun (fsLit "defaultSigD")                  defaultSigDIdKey forImpDName                      = libFun (fsLit "forImpD")                      forImpDIdKey pragInlDName                     = libFun (fsLit "pragInlD")                     pragInlDIdKey@@ -429,12 +431,13 @@ recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey  -- data Type = ...-forallTName, varTName, conTName, infixTName, tupleTName, unboxedTupleTName,-    unboxedSumTName, arrowTName, listTName, appTName, appKindTName,-    sigTName, equalityTName, litTName, promotedTName,+forallTName, forallVisTName, varTName, conTName, infixTName, tupleTName,+    unboxedTupleTName, unboxedSumTName, arrowTName, listTName, appTName,+    appKindTName, sigTName, equalityTName, litTName, promotedTName,     promotedTupleTName, promotedNilTName, promotedConsTName,     wildCardTName, implicitParamTName :: Name forallTName         = libFun (fsLit "forallT")        forallTIdKey+forallVisTName      = libFun (fsLit "forallVisT")     forallVisTIdKey varTName            = libFun (fsLit "varT")           varTIdKey conTName            = libFun (fsLit "conT")           conTIdKey tupleTName          = libFun (fsLit "tupleT")         tupleTIdKey@@ -725,7 +728,7 @@ returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,     mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,     mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeQIdKey,-    unsafeTExpCoerceIdKey :: Unique+    unsafeTExpCoerceIdKey, liftTypedIdKey :: Unique returnQIdKey        = mkPreludeMiscIdUnique 200 bindQIdKey          = mkPreludeMiscIdUnique 201 sequenceQIdKey      = mkPreludeMiscIdUnique 202@@ -740,6 +743,7 @@ unTypeIdKey          = mkPreludeMiscIdUnique 211 unTypeQIdKey         = mkPreludeMiscIdUnique 212 unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 213+liftTypedIdKey        = mkPreludeMiscIdUnique 214   -- data Lit = ...@@ -865,7 +869,8 @@     openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,     newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,     infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,-    patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey :: Unique+    patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey,+    kiSigDIdKey :: Unique funDIdKey                         = mkPreludeMiscIdUnique 320 valDIdKey                         = mkPreludeMiscIdUnique 321 dataDIdKey                        = mkPreludeMiscIdUnique 322@@ -898,6 +903,7 @@ patSynSigDIdKey                   = mkPreludeMiscIdUnique 349 pragCompleteDIdKey                = mkPreludeMiscIdUnique 350 implicitParamBindDIdKey           = mkPreludeMiscIdUnique 351+kiSigDIdKey                       = mkPreludeMiscIdUnique 352  -- type Cxt = ... cxtIdKey :: Unique@@ -950,79 +956,80 @@ recordPatSynIdKey = mkPreludeMiscIdUnique 382  -- data Type = ...-forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey,-    unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, appKindTIdKey,-    sigTIdKey, equalityTIdKey, litTIdKey, promotedTIdKey,+forallTIdKey, forallVisTIdKey, varTIdKey, conTIdKey, tupleTIdKey,+    unboxedTupleTIdKey, unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey,+    appKindTIdKey, sigTIdKey, equalityTIdKey, litTIdKey, promotedTIdKey,     promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey,     wildCardTIdKey, implicitParamTIdKey, infixTIdKey :: Unique forallTIdKey        = mkPreludeMiscIdUnique 390-varTIdKey           = mkPreludeMiscIdUnique 391-conTIdKey           = mkPreludeMiscIdUnique 392-tupleTIdKey         = mkPreludeMiscIdUnique 393-unboxedTupleTIdKey  = mkPreludeMiscIdUnique 394-unboxedSumTIdKey    = mkPreludeMiscIdUnique 395-arrowTIdKey         = mkPreludeMiscIdUnique 396-listTIdKey          = mkPreludeMiscIdUnique 397-appTIdKey           = mkPreludeMiscIdUnique 398-appKindTIdKey       = mkPreludeMiscIdUnique 399-sigTIdKey           = mkPreludeMiscIdUnique 400-equalityTIdKey      = mkPreludeMiscIdUnique 401-litTIdKey           = mkPreludeMiscIdUnique 402-promotedTIdKey      = mkPreludeMiscIdUnique 403-promotedTupleTIdKey = mkPreludeMiscIdUnique 404-promotedNilTIdKey   = mkPreludeMiscIdUnique 405-promotedConsTIdKey  = mkPreludeMiscIdUnique 406-wildCardTIdKey      = mkPreludeMiscIdUnique 407-implicitParamTIdKey = mkPreludeMiscIdUnique 408-infixTIdKey         = mkPreludeMiscIdUnique 409+forallVisTIdKey     = mkPreludeMiscIdUnique 391+varTIdKey           = mkPreludeMiscIdUnique 392+conTIdKey           = mkPreludeMiscIdUnique 393+tupleTIdKey         = mkPreludeMiscIdUnique 394+unboxedTupleTIdKey  = mkPreludeMiscIdUnique 395+unboxedSumTIdKey    = mkPreludeMiscIdUnique 396+arrowTIdKey         = mkPreludeMiscIdUnique 397+listTIdKey          = mkPreludeMiscIdUnique 398+appTIdKey           = mkPreludeMiscIdUnique 399+appKindTIdKey       = mkPreludeMiscIdUnique 400+sigTIdKey           = mkPreludeMiscIdUnique 401+equalityTIdKey      = mkPreludeMiscIdUnique 402+litTIdKey           = mkPreludeMiscIdUnique 403+promotedTIdKey      = mkPreludeMiscIdUnique 404+promotedTupleTIdKey = mkPreludeMiscIdUnique 405+promotedNilTIdKey   = mkPreludeMiscIdUnique 406+promotedConsTIdKey  = mkPreludeMiscIdUnique 407+wildCardTIdKey      = mkPreludeMiscIdUnique 408+implicitParamTIdKey = mkPreludeMiscIdUnique 409+infixTIdKey         = mkPreludeMiscIdUnique 410  -- data TyLit = ... numTyLitIdKey, strTyLitIdKey :: Unique-numTyLitIdKey = mkPreludeMiscIdUnique 410-strTyLitIdKey = mkPreludeMiscIdUnique 411+numTyLitIdKey = mkPreludeMiscIdUnique 411+strTyLitIdKey = mkPreludeMiscIdUnique 412  -- data TyVarBndr = ... plainTVIdKey, kindedTVIdKey :: Unique-plainTVIdKey       = mkPreludeMiscIdUnique 412-kindedTVIdKey      = mkPreludeMiscIdUnique 413+plainTVIdKey       = mkPreludeMiscIdUnique 413+kindedTVIdKey      = mkPreludeMiscIdUnique 414  -- data Role = ... nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique-nominalRIdKey          = mkPreludeMiscIdUnique 414-representationalRIdKey = mkPreludeMiscIdUnique 415-phantomRIdKey          = mkPreludeMiscIdUnique 416-inferRIdKey            = mkPreludeMiscIdUnique 417+nominalRIdKey          = mkPreludeMiscIdUnique 415+representationalRIdKey = mkPreludeMiscIdUnique 416+phantomRIdKey          = mkPreludeMiscIdUnique 417+inferRIdKey            = mkPreludeMiscIdUnique 418  -- data Kind = ... varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey,   starKIdKey, constraintKIdKey :: Unique-varKIdKey         = mkPreludeMiscIdUnique 418-conKIdKey         = mkPreludeMiscIdUnique 419-tupleKIdKey       = mkPreludeMiscIdUnique 420-arrowKIdKey       = mkPreludeMiscIdUnique 421-listKIdKey        = mkPreludeMiscIdUnique 422-appKIdKey         = mkPreludeMiscIdUnique 423-starKIdKey        = mkPreludeMiscIdUnique 424-constraintKIdKey  = mkPreludeMiscIdUnique 425+varKIdKey         = mkPreludeMiscIdUnique 419+conKIdKey         = mkPreludeMiscIdUnique 420+tupleKIdKey       = mkPreludeMiscIdUnique 421+arrowKIdKey       = mkPreludeMiscIdUnique 422+listKIdKey        = mkPreludeMiscIdUnique 423+appKIdKey         = mkPreludeMiscIdUnique 424+starKIdKey        = mkPreludeMiscIdUnique 425+constraintKIdKey  = mkPreludeMiscIdUnique 426  -- data FamilyResultSig = ... noSigIdKey, kindSigIdKey, tyVarSigIdKey :: Unique-noSigIdKey        = mkPreludeMiscIdUnique 426-kindSigIdKey      = mkPreludeMiscIdUnique 427-tyVarSigIdKey     = mkPreludeMiscIdUnique 428+noSigIdKey        = mkPreludeMiscIdUnique 427+kindSigIdKey      = mkPreludeMiscIdUnique 428+tyVarSigIdKey     = mkPreludeMiscIdUnique 429  -- data InjectivityAnn = ... injectivityAnnIdKey :: Unique-injectivityAnnIdKey = mkPreludeMiscIdUnique 429+injectivityAnnIdKey = mkPreludeMiscIdUnique 430  -- data Callconv = ... cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey,   javaScriptCallIdKey :: Unique-cCallIdKey          = mkPreludeMiscIdUnique 430-stdCallIdKey        = mkPreludeMiscIdUnique 431-cApiCallIdKey       = mkPreludeMiscIdUnique 432-primCallIdKey       = mkPreludeMiscIdUnique 433-javaScriptCallIdKey = mkPreludeMiscIdUnique 434+cCallIdKey          = mkPreludeMiscIdUnique 431+stdCallIdKey        = mkPreludeMiscIdUnique 432+cApiCallIdKey       = mkPreludeMiscIdUnique 433+primCallIdKey       = mkPreludeMiscIdUnique 434+javaScriptCallIdKey = mkPreludeMiscIdUnique 435  -- data Safety = ... unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique@@ -1076,8 +1083,9 @@ ************************************************************************ -} -lift_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName+lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName lift_RDR     = nameRdrName liftName+liftTyped_RDR = nameRdrName liftTypedName mkNameG_dRDR = nameRdrName mkNameG_dName mkNameG_vRDR = nameRdrName mkNameG_vName
compiler/rename/RnBinds.hs view
@@ -30,7 +30,7 @@  import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) -import HsSyn+import GHC.Hs import TcRnMonad import RnTypes import RnPat@@ -38,7 +38,8 @@ import RnEnv import RnFixity import RnUtils          ( HsDocContext(..), mapFvRn, extendTyVarEnvFVRn-                        , checkDupRdrNames, warnUnusedLocalBinds+                        , checkDupRdrNames, warnUnusedLocalBinds,+                        checkUnusedRecordWildcard                         , checkDupAndShadowedNames, bindLocalNamesFV ) import DynFlags import Module@@ -48,13 +49,14 @@ import RdrName          ( RdrName, rdrNameOcc ) import SrcLoc import ListSetOps       ( findDupsEq )-import BasicTypes       ( RecFlag(..) )+import BasicTypes       ( RecFlag(..), TypeOrKind(..) ) import Digraph          ( SCC(..) ) import Bag import Util import Outputable import UniqSet import Maybes           ( orElse )+import OrdList import qualified GHC.LanguageExtensions as LangExt  import Control.Monad@@ -214,19 +216,19 @@     (thing, fvs_thing) <- thing_inside (HsIPBinds x binds') fv_binds     return (thing, fvs_thing `plusFV` fv_binds) -rnLocalBindsAndThen (XHsLocalBindsLR _) _ = panic "rnLocalBindsAndThen"+rnLocalBindsAndThen (XHsLocalBindsLR nec) _ = noExtCon nec  rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars) rnIPBinds (IPBinds _ ip_binds ) = do     (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds-    return (IPBinds noExt ip_binds', plusFVs fvs_s)-rnIPBinds (XHsIPBinds _) = panic "rnIPBinds"+    return (IPBinds noExtField ip_binds', plusFVs fvs_s)+rnIPBinds (XHsIPBinds nec) = noExtCon nec  rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars) rnIPBind (IPBind _ ~(Left n) expr) = do     (expr',fvExpr) <- rnLExpr expr-    return (IPBind noExt (Left n) expr', fvExpr)-rnIPBind (XIPBind _) = panic "rnIPBind"+    return (IPBind noExtField (Left n) expr', fvExpr)+rnIPBind (XIPBind nec) = noExtCon nec  {- ************************************************************************@@ -246,7 +248,7 @@           -- Check for duplicates and shadowing          -- Must do this *after* renaming the patterns-         -- See Note [Collect binders only after renaming] in HsUtils+         -- See Note [Collect binders only after renaming] in GHC.Hs.Utils           -- We need to check for dups here because we          -- don't don't bind all of the variables from the ValBinds at once@@ -306,7 +308,7 @@                 -- Note [Pattern synonym builders don't yield dependencies]                 -- But psb_fvs /does/ include those builder fvs.  So we                 -- add them back in here to avoid bogus warnings about-                -- unused variables (Trac #12548)+                -- unused variables (#12548)               valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs                                      `plusDU` usesOnly patsyn_fvs@@ -362,7 +364,12 @@         ; let real_uses = findUses dus result_fvs               -- Insert fake uses for variables introduced implicitly by               -- wildcards (#4404)-              implicit_uses = hsValBindsImplicits binds'+              rec_uses = hsValBindsImplicits binds'+              implicit_uses = mkNameSet $ concatMap snd+                                        $ rec_uses+        ; mapM_ (\(loc, ns) ->+                    checkUnusedRecordWildcard loc real_uses (Just ns))+                rec_uses         ; warnUnusedLocalBinds bound_names                                       (real_uses `unionNameSet` implicit_uses) @@ -416,19 +423,19 @@ rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name })   = do { name <- applyNameMaker name_maker rdr_name        ; return (bind { fun_id = name-                      , fun_ext = noExt }) }+                      , fun_ext = noExtField }) }  rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname })   | isTopRecNameMaker name_maker   = do { addLocM checkConName rdrname        ; name <- lookupLocatedTopBndrRn rdrname   -- Should be in scope already-       ; return (PatSynBind x psb{ psb_ext = noExt, psb_id = name }) }+       ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) }    | otherwise  -- Pattern synonym, not at top level   = do { addErr localPatternSynonymErr  -- Complain, but make up a fake                                         -- name so that we can carry on        ; name <- applyNameMaker name_maker rdrname-       ; return (PatSynBind x psb{ psb_ext = noExt, psb_id = name }) }+       ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) }   where     localPatternSynonymErr :: SDoc     localPatternSynonymErr@@ -530,7 +537,7 @@ * A strict pattern binding; that is, one with an outermost bang      !Just _ = e   This can fail, so unlike the lazy variant, it is not a no-op.-  Moreover, Trac #13646 argues that even for single constructor+  Moreover, #13646 argues that even for single constructor   types, you might want to write the constructor.  See also #9127.  * A splice pattern@@ -562,7 +569,7 @@ -- Dependency analysis; this is important so that -- unused-binding reporting is accurate depAnalBinds binds_w_dus-  = (map get_binds sccs, map get_du sccs)+  = (map get_binds sccs, toOL $ map get_du sccs)   where     sccs = depAnal (\(_, defs, _) -> defs)                    (\(_, _, uses) -> nonDetEltsUniqSet uses)@@ -623,7 +630,7 @@    add_one_sig env (L loc (FixitySig _ names fixity)) =      foldlM add_one env [ (loc,name_loc,name,fixity)                         | L name_loc name <- names ]-   add_one_sig _ (L _ (XFixitySig _)) = panic "makeMiniFixityEnv"+   add_one_sig _ (L _ (XFixitySig nec)) = noExtCon nec     add_one env (loc, name_loc, name,fixity) = do      { -- this fixity decl is a duplicate iff@@ -734,7 +741,7 @@       = hang (text "Illegal pattern synonym declaration")            2 (text "Use -XPatternSynonyms to enable this extension") -rnPatSynBind _ (XPatSynBind _) = panic "rnPatSynBind"+rnPatSynBind _ (XPatSynBind nec) = noExtCon nec  {- Note [Renaming pattern synonym variables]@@ -799,7 +806,7 @@    (which is then used for dependency analysis)  * But we /do/ include them in the psb_fvs for the PatSynBind  * In rnValBinds we record these builder uses, to avoid bogus-   unused-variable warnings (Trac #12548)+   unused-variable warnings (#12548) -}  {- *********************************************************************@@ -846,7 +853,7 @@              -- for instance decls too         -- Rename the bindings LHSs-       ; binds' <- foldrBagM (rnMethodBindLHS is_cls_decl cls) emptyBag binds+       ; binds' <- foldrM (rnMethodBindLHS is_cls_decl cls) emptyBag binds         -- Rename the pragmas and signatures        -- Annoyingly the type variables /are/ in scope for signatures, but@@ -868,7 +875,7 @@        ; scoped_tvs  <- xoptM LangExt.ScopedTypeVariables        ; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $               do { binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn other_sigs')) binds'-                 ; let bind_fvs = foldrBag (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2)+                 ; let bind_fvs = foldr (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2)                                            emptyFVs binds_w_dus                  ; return (mapBag fstOf3 binds_w_dus, bind_fvs) } @@ -889,7 +896,7 @@   = setSrcSpan loc $ do     do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name                      -- We use the selector name as the binder-       ; let bind' = bind { fun_id = sel_name, fun_ext = noExt }+       ; let bind' = bind { fun_id = sel_name, fun_ext = noExtField }        ; return (L loc bind' `consBag` rest ) }  -- Report error for all other forms of bindings@@ -953,29 +960,29 @@  renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars) renameSig _ (IdSig _ x)-  = return (IdSig noExt x, emptyFVs)    -- Actually this never occurs+  = return (IdSig noExtField x, emptyFVs)    -- Actually this never occurs  renameSig ctxt sig@(TypeSig _ vs ty)   = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs         ; let doc = TypeSigCtx (ppr_sig_bndrs vs)         ; (new_ty, fvs) <- rnHsSigWcType BindUnlessForall doc ty-        ; return (TypeSig noExt new_vs new_ty, fvs) }+        ; return (TypeSig noExtField new_vs new_ty, fvs) }  renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)   = do  { defaultSigs_on <- xoptM LangExt.DefaultSignatures         ; when (is_deflt && not defaultSigs_on) $           addErr (defaultSigErr sig)         ; new_v <- mapM (lookupSigOccRn ctxt sig) vs-        ; (new_ty, fvs) <- rnHsSigType ty_ctxt ty-        ; return (ClassOpSig noExt is_deflt new_v new_ty, fvs) }+        ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty+        ; return (ClassOpSig noExtField is_deflt new_v new_ty, fvs) }   where     (v1:_) = vs     ty_ctxt = GenericCtx (text "a class method signature for"                           <+> quotes (ppr v1))  renameSig _ (SpecInstSig _ src ty)-  = do  { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx ty-        ; return (SpecInstSig noExt src new_ty,fvs) }+  = do  { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx TypeLevel ty+        ; return (SpecInstSig noExtField src new_ty,fvs) }  -- {-# SPECIALISE #-} pragmas can refer to imported Ids -- so, in the top-level case (when mb_names is Nothing)@@ -986,37 +993,37 @@                      TopSigCtxt {} -> lookupLocatedOccRn v                      _             -> lookupSigOccRn ctxt sig v         ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys-        ; return (SpecSig noExt new_v new_ty inl, fvs) }+        ; return (SpecSig noExtField new_v new_ty inl, fvs) }   where     ty_ctxt = GenericCtx (text "a SPECIALISE signature for"                           <+> quotes (ppr v))     do_one (tys,fvs) ty-      = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt ty+      = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel ty            ; return ( new_ty:tys, fvs_ty `plusFV` fvs) }  renameSig ctxt sig@(InlineSig _ v s)   = do  { new_v <- lookupSigOccRn ctxt sig v-        ; return (InlineSig noExt new_v s, emptyFVs) }+        ; return (InlineSig noExtField new_v s, emptyFVs) }  renameSig ctxt (FixSig _ fsig)   = do  { new_fsig <- rnSrcFixityDecl ctxt fsig-        ; return (FixSig noExt new_fsig, emptyFVs) }+        ; return (FixSig noExtField new_fsig, emptyFVs) }  renameSig ctxt sig@(MinimalSig _ s (L l bf))   = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf-       return (MinimalSig noExt s (L l new_bf), emptyFVs)+       return (MinimalSig noExtField s (L l new_bf), emptyFVs)  renameSig ctxt sig@(PatSynSig _ vs ty)   = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs-        ; (ty', fvs) <- rnHsSigType ty_ctxt ty-        ; return (PatSynSig noExt new_vs ty', fvs) }+        ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty+        ; return (PatSynSig noExtField new_vs ty', fvs) }   where     ty_ctxt = GenericCtx (text "a pattern synonym signature for"                           <+> ppr_sig_bndrs vs)  renameSig ctxt sig@(SCCFunSig _ st v s)   = do  { new_v <- lookupSigOccRn ctxt sig v-        ; return (SCCFunSig noExt st new_v s, emptyFVs) }+        ; return (SCCFunSig noExtField st new_v s, emptyFVs) }  -- COMPLETE Sigs can refer to imported IDs which is why we use -- lookupLocatedOccRn rather than lookupSigOccRn@@ -1029,7 +1036,7 @@          -- Why 'any'? See Note [Orphan COMPLETE pragmas]          addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError -       return (CompleteMatchSig noExt s (L l new_bf) new_mty, emptyFVs)+       return (CompleteMatchSig noExtField s (L l new_bf) new_mty, emptyFVs)   where     orphanError :: SDoc     orphanError =@@ -1037,7 +1044,7 @@       text "A COMPLETE pragma must mention at least one data constructor" $$       text "or pattern synonym defined in the same module." -renameSig _ (XSig _) = panic "renameSig"+renameSig _ (XSig nec) = noExtCon nec  {- Note [Orphan COMPLETE pragmas]@@ -1064,7 +1071,7 @@ ppr_sig_bndrs :: [Located RdrName] -> SDoc ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) -okHsSig :: HsSigCtxt -> LSig a -> Bool+okHsSig :: HsSigCtxt -> LSig (GhcPass a) -> Bool okHsSig ctxt (L _ sig)   = case (sig, ctxt) of      (ClassOpSig {}, ClsDeclCtxt {})  -> True@@ -1105,7 +1112,7 @@      (CompleteMatchSig {}, TopSigCtxt {} ) -> True      (CompleteMatchSig {}, _)              -> False -     (XSig _, _) -> panic "okHsSig"+     (XSig nec, _) -> noExtCon nec  ------------------- findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)]@@ -1161,7 +1168,7 @@        ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))        ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms        ; return (mkMatchGroup origin new_ms, ms_fvs) }-rnMatchGroup _ _ (XMatchGroup {}) = panic "rnMatchGroup"+rnMatchGroup _ _ (XMatchGroup nec) = noExtCon nec  rnMatch :: Outputable (body GhcPs) => HsMatchContext Name         -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))@@ -1181,9 +1188,9 @@                       (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ })                                             -> mf { mc_fun = L lf funid }                       _                     -> ctxt-        ; return (Match { m_ext = noExt, m_ctxt = mf', m_pats = pats'+        ; return (Match { m_ext = noExtField, m_ctxt = mf', m_pats = pats'                         , m_grhss = grhss'}, grhss_fvs ) }}-rnMatch' _ _ (XMatch _) = panic "rnMatch'"+rnMatch' _ _ (XMatch nec) = noExtCon nec  emptyCaseErr :: HsMatchContext Name -> SDoc emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)@@ -1209,8 +1216,8 @@ rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds))   = rnLocalBindsAndThen binds   $ \ binds' _ -> do     (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss-    return (GRHSs noExt grhss' (L l binds'), fvGRHSs)-rnGRHSs _ _ (XGRHSs _) = panic "rnGRHSs"+    return (GRHSs noExtField grhss' (L l binds'), fvGRHSs)+rnGRHSs _ _ (XGRHSs nec) = noExtCon nec  rnGRHS :: HsMatchContext Name        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))@@ -1230,7 +1237,7 @@         ; unless (pattern_guards_allowed || is_standard_guard guards')                  (addWarn NoReason (nonStdGuardErr guards')) -        ; return (GRHS noExt guards' rhs', fvs) }+        ; return (GRHS noExtField guards' rhs', fvs) }   where         -- Standard Haskell 1.4 guards are just a single boolean         -- expression, rather than a list of qualifiers as in the@@ -1238,7 +1245,7 @@     is_standard_guard []                  = True     is_standard_guard [L _ (BodyStmt {})] = True     is_standard_guard _                   = False-rnGRHS' _ _ (XGRHS _) = panic "rnGRHS'"+rnGRHS' _ _ (XGRHS nec) = noExtCon nec  {- *********************************************************@@ -1261,8 +1268,8 @@         -- return a fixity sig for each (slightly odd)     rn_decl (FixitySig _ fnames fixity)       = do names <- concatMapM lookup_one fnames-           return (FixitySig noExt names fixity)-    rn_decl (XFixitySig _) = panic "rnSrcFixityDecl"+           return (FixitySig noExtField names fixity)+    rn_decl (XFixitySig nec) = noExtCon nec      lookup_one :: Located RdrName -> RnM [Located Name]     lookup_one (L name_loc rdr_name)
compiler/rename/RnEnv.hs view
@@ -42,13 +42,13 @@      ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import LoadIface        ( loadInterfaceForName, loadSrcInterface_maybe ) import IfaceEnv-import HsSyn+import GHC.Hs import RdrName import HscTypes import TcEnv@@ -68,6 +68,7 @@ import BasicTypes       ( pprWarningTxtForMsg, TopLevelFlag(..)) import SrcLoc import Outputable+import UniqSet          ( uniqSetAny ) import Util import Maybes import DynFlags@@ -220,7 +221,7 @@  Note [Type and class operator definitions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We want to reject all of these unless we have -XTypeOperators (Trac #3265)+We want to reject all of these unless we have -XTypeOperators (#3265)    data a :*: b  = ...    class a :*: b where ...    data (:*:) a b  = ....@@ -518,7 +519,7 @@ Whenever we fail to find the field or it is not in scope, mb_field will be False, and we fall back on looking it up normally using lookupGlobalOccRn.  We don't report an error immediately because the-actual problem might be located elsewhere.  For example (Trac #9975):+actual problem might be located elsewhere.  For example (#9975):     data Test = Test { x :: Int }    pattern Test wat = Test { x = wat }@@ -531,7 +532,7 @@ (nonexistent) fields of the pattern synonym.  Alternatively, the scope check can fail due to Template Haskell.-Consider (Trac #12130):+Consider (#12130):     module Foo where      import M@@ -844,7 +845,7 @@  So how can we get multiple gres in lookupExactOcc_maybe?  Because in TH we might use the same TH NameU in two different name spaces.-eg (Trac #7241):+eg (#7241):    $(newName "Foo" >>= \o -> return [DataD [] o [] [RecC o []] [''Show]]) Here we generate a type constructor and data constructor with the same unique, but different name spaces.@@ -972,7 +973,7 @@  {- Note [Promoted variables in types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (Trac #12686):+Consider this (#12686):    x = True    data Bad = Bad 'x @@ -1054,7 +1055,10 @@ -- lookupInfoOccRn is intended for use in GHCi's ":info" command -- It finds all the GREs that RdrName could mean, not complaining -- about ambiguity, but rather returning them all--- C.f. Trac #9881+-- C.f. #9881+-- lookupInfoOccRn is also used in situations where we check for+-- at least one definition of the RdrName, not complaining about+-- multiple definitions. (See #17832) lookupInfoOccRn rdr_name =   lookupExactOrOrig rdr_name (:[]) $     do { rdr_env <- getGlobalRdrEnv@@ -1188,7 +1192,7 @@ Note [Handling of deprecations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * We report deprecations at each *occurrence* of the deprecated thing-  (see Trac #5867)+  (see #5867)  * We do not report deprecations for locally-defined names. For a   start, we may be exporting a deprecated thing. Also we may use a@@ -1203,7 +1207,7 @@ -}  addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM ()--- Remember use of in-scope data constructors (Trac #7969)+-- Remember use of in-scope data constructors (#7969) addUsedDataCons rdr_env tycon   = addUsedGREs [ gre                 | dc <- tyConDataCons tycon@@ -1265,10 +1269,10 @@  lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt lookupImpDeprec iface gre-  = mi_warn_fn iface (greOccName gre) `mplus`  -- Bleat if the thing,+  = mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus`  -- Bleat if the thing,     case gre_par gre of                      -- or its parent, is warn'd-       ParentIs  p              -> mi_warn_fn iface (nameOccName p)-       FldParent { par_is = p } -> mi_warn_fn iface (nameOccName p)+       ParentIs  p              -> mi_warn_fn (mi_final_exts iface) (nameOccName p)+       FldParent { par_is = p } -> mi_warn_fn (mi_final_exts iface) (nameOccName p)        NoParent                 -> Nothing  {-@@ -1374,7 +1378,7 @@         f :: Int -> Int         g x = x We don't want to say 'f' is out of scope; instead, we want to-return the imported 'f', so that later on the reanamer will+return the imported 'f', so that later on the renamer will correctly report "misplaced type sig".  Note [Signatures for top level things]@@ -1462,7 +1466,9 @@       RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns)       LocalBindCtxt ns -> lookup_group ns       ClsDeclCtxt  cls -> lookup_cls_op cls-      InstDeclCtxt ns  -> lookup_top (`elemNameSet` ns)+      InstDeclCtxt ns  -> if uniqSetAny isUnboundName ns -- #16610+                          then return (Right $ mkUnboundNameRdr rdr_name)+                          else lookup_top (`elemNameSet` ns)   where     lookup_cls_op cls       = lookupSubBndrOcc True cls doc rdr_name@@ -1472,18 +1478,30 @@     lookup_top keep_me       = do { env <- getGlobalRdrEnv            ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)+                 names_in_scope = -- If rdr_name lacks a binding, only+                                  -- recommend alternatives from related+                                  -- namespaces. See #17593.+                                  filter (\n -> nameSpacesRelated+                                                  (rdrNameSpace rdr_name)+                                                  (nameNameSpace n))+                                $ map gre_name+                                $ filter isLocalGRE+                                $ globalRdrEnvElts env+                 candidates_msg = candidates names_in_scope            ; case filter (keep_me . gre_name) all_gres of-               [] | null all_gres -> bale_out_with Outputable.empty+               [] | null all_gres -> bale_out_with candidates_msg                   | otherwise     -> bale_out_with local_msg                (gre:_)            -> return (Right (gre_name gre)) }      lookup_group bound_names  -- Look in the local envt (not top level)       = do { mname <- lookupLocalOccRn_maybe rdr_name+           ; env <- getLocalRdrEnv+           ; let candidates_msg = candidates $ localRdrEnvElts env            ; case mname of                Just n                  | n `elemNameSet` bound_names -> return (Right n)                  | otherwise                   -> bale_out_with local_msg-               Nothing                         -> bale_out_with Outputable.empty }+               Nothing                         -> bale_out_with candidates_msg }      bale_out_with msg         = return (Left (sep [ text "The" <+> what@@ -1494,7 +1512,23 @@     local_msg = parens $ text "The"  <+> what <+> ptext (sLit "must be given where")                            <+> quotes (ppr rdr_name) <+> text "is declared" +    -- Identify all similar names and produce a message listing them+    candidates :: [Name] -> MsgDoc+    candidates names_in_scope+      = case similar_names of+          []  -> Outputable.empty+          [n] -> text "Perhaps you meant" <+> pp_item n+          _   -> sep [ text "Perhaps you meant one of these:"+                     , nest 2 (pprWithCommas pp_item similar_names) ]+      where+        similar_names+          = fuzzyLookup (unpackFS $ occNameFS $ rdrNameOcc rdr_name)+                        $ map (\x -> ((unpackFS $ occNameFS $ nameOccName x), x))+                              names_in_scope +        pp_item x = quotes (ppr x) <+> parens (pprDefinedAt x)++ --------------- lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)] -- GHC extension: look up both the tycon and data con or variable.@@ -1634,10 +1668,10 @@ lookupSyntaxNames std_names   = do { rebindable_on <- xoptM LangExt.RebindableSyntax        ; if not rebindable_on then-             return (map (HsVar noExt . noLoc) std_names, emptyFVs)+             return (map (HsVar noExtField . noLoc) std_names, emptyFVs)         else           do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names-             ; return (map (HsVar noExt . noLoc) usr_names, mkFVs usr_names) } }+             ; return (map (HsVar noExtField . noLoc) usr_names, mkFVs usr_names) } }  -- Error messages @@ -1660,6 +1694,6 @@     --     --   $(pure [ValD (VarP 'succ) (NormalB (ConE 'True)) []])     ---    -- (See Trac #13968.)+    -- (See #13968.)   where     occ = rdrNameOcc $ filterCTuple name
compiler/rename/RnExpr.hs view
@@ -20,13 +20,13 @@         rnLExpr, rnExpr, rnStmts    ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import RnBinds   ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,                    rnMatchGroup, rnGRHS, makeMiniFixityEnv)-import HsSyn+import GHC.Hs import TcEnv            ( isBrackStage ) import TcRnMonad import Module           ( getModule )@@ -35,7 +35,8 @@ import RnUtils          ( HsDocContext(..), bindLocalNamesFV, checkDupNames                         , bindLocalNames                         , mapMaybeFvRn, mapFvRn-                        , warnUnusedLocalBinds, typeAppErr )+                        , warnUnusedLocalBinds, typeAppErr+                        , checkUnusedRecordWildcard ) import RnUnbound        ( reportUnboundName ) import RnSplice         ( rnBracket, rnSpliceExpr, checkThLocalName ) import RnTypes@@ -99,7 +100,7 @@  = do { this_mod <- getModule       ; when (nameIsLocalOrFrom this_mod name) $         checkThLocalName name-      ; return (HsVar noExt (L l name), unitFV name) }+      ; return (HsVar noExtField (L l name), unitFV name) }  rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars) rnUnboundVar v@@ -111,34 +112,40 @@                 ; uv <- if startsWithUnderscore occ                         then return (TrueExprHole occ)                         else OutOfScope occ <$> getGlobalRdrEnv-                ; return (HsUnboundVar noExt uv, emptyFVs) }+                ; return (HsUnboundVar noExtField uv, emptyFVs) }          else -- Fail immediately (qualified name)              do { n <- reportUnboundName v-                ; return (HsVar noExt (noLoc n), emptyFVs) } }+                ; return (HsVar noExtField (noLoc n), emptyFVs) } }  rnExpr (HsVar _ (L l v))   = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields        ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v+       ; dflags <- getDynFlags        ; case mb_name of {            Nothing -> rnUnboundVar v ;            Just (Left name)               | name == nilDataConName -- Treat [] as an ExplicitList, so that                                        -- OverloadedLists works correctly-              -> rnExpr (ExplicitList noExt Nothing [])+                                       -- Note [Empty lists] in GHC.Hs.Expr+              , xopt LangExt.OverloadedLists dflags+              -> rnExpr (ExplicitList noExtField Nothing [])                | otherwise               -> finishHsVar (L l name) ;             Just (Right [s]) ->-              return ( HsRecFld noExt (Unambiguous s (L l v) ), unitFV s) ;+              return ( HsRecFld noExtField (Unambiguous s (L l v) ), unitFV s) ;            Just (Right fs@(_:_:_)) ->-              return ( HsRecFld noExt (Ambiguous noExt (L l v))+              return ( HsRecFld noExtField (Ambiguous noExtField (L l v))                      , mkFVs fs);            Just (Right [])         -> panic "runExpr/HsVar" } }  rnExpr (HsIPVar x v)   = return (HsIPVar x v, emptyFVs) +rnExpr (HsUnboundVar x v)+  = return (HsUnboundVar x v, emptyFVs)+ rnExpr (HsOverLabel x _ v)   = do { rebindable_on <- xoptM LangExt.RebindableSyntax        ; if rebindable_on@@ -204,8 +211,6 @@  ------------------------------------------ -- Template Haskell extensions--- Don't ifdef-GHCI them because we want to fail gracefully--- (not with an rnExpr crash) in a stage-1 compiler. rnExpr e@(HsBracket _ br_body) = rnBracket e br_body  rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice@@ -286,9 +291,9 @@   where     rnTupArg (L l (Present x e)) = do { (e',fvs) <- rnLExpr e                                       ; return (L l (Present x e'), fvs) }-    rnTupArg (L l (Missing _)) = return (L l (Missing noExt)+    rnTupArg (L l (Missing _)) = return (L l (Missing noExtField)                                         , emptyFVs)-    rnTupArg (L _ (XTupArg {})) = panic "rnExpr.XTupArg"+    rnTupArg (L _ (XTupArg nec)) = noExtCon nec  rnExpr (ExplicitSum x alt arity expr)   = do { (expr', fvs) <- rnLExpr expr@@ -300,18 +305,18 @@        ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds        ; (flds', fvss) <- mapAndUnzipM rn_field flds        ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }-       ; return (RecordCon { rcon_ext = noExt+       ; return (RecordCon { rcon_ext = noExtField                            , rcon_con_name = con_lname, rcon_flds = rec_binds' }                 , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }   where-    mk_hs_var l n = HsVar noExt (L l n)+    mk_hs_var l n = HsVar noExtField (L l n)     rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)                             ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }  rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })   = do  { (expr', fvExpr) <- rnLExpr expr         ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds-        ; return (RecordUpd { rupd_ext = noExt, rupd_expr = expr'+        ; return (RecordUpd { rupd_ext = noExtField, rupd_expr = expr'                             , rupd_flds = rbinds' }                  , fvExpr `plusFV` fvRbinds) } @@ -319,7 +324,7 @@   = do  { (pty', fvTy)    <- rnHsSigWcType BindUnlessForall ExprWithTySigCtx pty         ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $                              rnLExpr expr-        ; return (ExprWithTySig noExt expr' pty', fvExpr `plusFV` fvTy) }+        ; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) }  rnExpr (HsIf x _ p b1 b2)   = do { (p', fvP) <- rnLExpr p@@ -345,24 +350,6 @@             return (ArithSeq x Nothing new_seq, fvs) }  {--These three are pattern syntax appearing in expressions.-Since all the symbols are reservedops we can simply reject them.-We return a (bogus) EWildPat in each case.--}--rnExpr (EWildPat _)  = return (hsHoleExpr, emptyFVs)   -- "_" is just a hole-rnExpr e@(EAsPat {})-  = do { opt_TypeApplications <- xoptM LangExt.TypeApplications-       ; let msg | opt_TypeApplications-                    = "Type application syntax requires a space before '@'"-                 | otherwise-                    = "Did you mean to enable TypeApplications?"-       ; patSynErr e (text msg)-       }-rnExpr e@(EViewPat {}) = patSynErr e empty-rnExpr e@(ELazyPat {}) = patSynErr e empty--{- ************************************************************************ *                                                                      *         Static values@@ -411,24 +398,9 @@       { (body',fvBody) <- rnCmdTop body       ; return (HsProc x pat' body', fvBody) } --- Ideally, these would be done in parsing, but to keep parsing simple, we do it here.-rnExpr e@(HsArrApp {})  = arrowFail e-rnExpr e@(HsArrForm {}) = arrowFail e- rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)         -- HsWrap -hsHoleExpr :: HsExpr (GhcPass id)-hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_"))--arrowFail :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)-arrowFail e-  = do { addErr (vcat [ text "Arrow command found where an expression was expected:"-                      , nest 2 (ppr e) ])-         -- Return a place-holder hole, so that we can carry on-         -- to report other errors-       ; return (hsHoleExpr, emptyFVs) }- ---------------------- -- See Note [Parsing sections] in Parser.y rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)@@ -473,7 +445,7 @@          ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd',                   fvCmd `plusFV` cmd_fvs) }-  rnCmdTop' (XCmdTop{}) = panic "rnCmdTop"+  rnCmdTop' (XCmdTop nec) = noExtCon nec  rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars) rnLCmd = wrapLocFstM rnCmd@@ -547,7 +519,7 @@         ; return ( HsCmdDo x (L l stmts'), fvs ) }  rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd)-rnCmd cmd@(XCmd {})      = pprPanic "rnCmd" (ppr cmd)+rnCmd     (XCmd nec)     = noExtCon nec  --------------------------------------------------- type CmdNeeds = FreeVars        -- Only inhabitants are@@ -579,7 +551,7 @@ methodNamesCmd (HsCmdCase _ _ matches)   = methodNamesMatch matches `addOneFV` choiceAName -methodNamesCmd (XCmd {}) = panic "methodNamesCmd"+methodNamesCmd (XCmd nec) = noExtCon nec  --methodNamesCmd _ = emptyFVs    -- Other forms can't occur in commands, but it's not convenient@@ -592,20 +564,20 @@   = plusFVs (map do_one ms)  where     do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss-    do_one (L _ (XMatch _)) = panic "methodNamesMatch.XMatch"-methodNamesMatch (XMatchGroup _) = panic "methodNamesMatch"+    do_one (L _ (XMatch nec)) = noExtCon nec+methodNamesMatch (XMatchGroup nec) = noExtCon nec  ------------------------------------------------- -- gaw 2004 methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss)-methodNamesGRHSs (XGRHSs _) = panic "methodNamesGRHSs"+methodNamesGRHSs (XGRHSs nec) = noExtCon nec  -------------------------------------------------  methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs-methodNamesGRHS (L _ (XGRHS _)) = panic "methodNamesGRHS"+methodNamesGRHS (L _ (XGRHS nec)) = noExtCon nec  --------------------------------------------------- methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars@@ -627,7 +599,7 @@ methodNamesStmt ApplicativeStmt{}              = emptyFVs    -- ParStmt and TransStmt can't occur in commands, but it's not    -- convenient to error here so we just do what's convenient-methodNamesStmt (XStmtLR {}) = panic "methodNamesStmt"+methodNamesStmt (XStmtLR nec) = noExtCon nec  {- ************************************************************************@@ -837,10 +809,10 @@                             -- The 'return' in a LastStmt is used only                             -- for MonadComp; and we don't want to report                             -- "non in scope: return" in other cases-                            -- Trac #15607+                            -- #15607          ; (thing,  fvs3) <- thing_inside []-        ; return (([(L loc (LastStmt noExt body' noret ret_op), fv_expr)]+        ; return (([(L loc (LastStmt noExtField body' noret ret_op), fv_expr)]                   , thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) }  rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside@@ -855,7 +827,7 @@                               -- Here "gd" is a guard          ; (thing, fvs3)    <- thing_inside []-        ; return ( ([(L loc (BodyStmt noExt body' then_op guard_op), fv_expr)]+        ; return ( ([(L loc (BodyStmt noExtField body' then_op guard_op), fv_expr)]                   , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }  rnStmt ctxt rnBody (L loc (BindStmt _ pat body _ _)) thing_inside@@ -867,7 +839,7 @@          ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do         { (thing, fvs3) <- thing_inside (collectPatBinders pat')-        ; return (( [( L loc (BindStmt noExt pat' body' bind_op fail_op)+        ; return (( [( L loc (BindStmt noExtField pat' body' bind_op fail_op)                      , fv_expr )]                   , thing),                   fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}@@ -877,7 +849,7 @@ rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside   = do  { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do         { (thing, fvs) <- thing_inside (collectLocalBinders binds')-        ; return ( ([(L loc (LetStmt noExt (L l binds')), bind_fvs)], thing)+        ; return ( ([(L loc (LetStmt noExtField (L l binds')), bind_fvs)], thing)                  , fvs) }  }  rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside@@ -915,7 +887,7 @@         ; (bind_op, fvs2)   <- lookupStmtName ctxt bindMName         ; (return_op, fvs3) <- lookupStmtName ctxt returnMName         ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside-        ; return (([(L loc (ParStmt noExt segs' mzip_op bind_op), fvs4)], thing)+        ; return (([(L loc (ParStmt noExtField segs' mzip_op bind_op), fvs4)], thing)                  , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }  rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form@@ -945,10 +917,10 @@        ; let all_fvs  = fvs1 `plusFV` fvs2 `plusFV` fvs3                              `plusFV` fvs4 `plusFV` fvs5              bndr_map = used_bndrs `zip` used_bndrs-             -- See Note [TransStmt binder map] in HsExpr+             -- See Note [TransStmt binder map] in GHC.Hs.Expr         ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map)-       ; return (([(L loc (TransStmt { trS_ext = noExt+       ; return (([(L loc (TransStmt { trS_ext = noExtField                                     , trS_stmts = stmts', trS_bndrs = bndr_map                                     , trS_by = by', trS_using = using', trS_form = form                                     , trS_ret = return_op, trS_bind = bind_op@@ -957,8 +929,8 @@ rnStmt _ _ (L _ ApplicativeStmt{}) _ =   panic "rnStmt: ApplicativeStmt" -rnStmt _ _ (L _ XStmtLR{}) _ =-  panic "rnStmt: XStmtLR"+rnStmt _ _ (L _ (XStmtLR nec)) _ =+  noExtCon nec  rnParallelStmts :: forall thing. HsStmtContext Name                 -> SyntaxExpr GhcRn@@ -989,7 +961,7 @@             ; let seg' = ParStmtBlock x stmts' used_bndrs return_op            ; return ((seg':segs', thing), fvs) }-    rn_segs _ _ (XParStmtBlock{}:_) = panic "rnParallelStmts"+    rn_segs _ _ (XParStmtBlock nec:_) = noExtCon nec      cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2     dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"@@ -1009,12 +981,12 @@   = do { rebindable_on <- xoptM LangExt.RebindableSyntax        ; if rebindable_on          then do { fm <- lookupOccRn (nameRdrName name)-                 ; return (HsVar noExt (noLoc fm), unitFV fm) }+                 ; return (HsVar noExtField (noLoc fm), unitFV fm) }          else not_rebindable }   | otherwise   = not_rebindable   where-    not_rebindable = return (HsVar noExt (noLoc name), emptyFVs)+    not_rebindable = return (HsVar noExtField (noLoc name), emptyFVs)  -- | Is this a context where we respect RebindableSyntax? -- but ListComp are never rebindable@@ -1089,13 +1061,16 @@           --    ...bring them and their fixities into scope         ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)               -- Fake uses of variables introduced implicitly (warning suppression, see #4404)-              implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv)+              rec_uses = lStmtsImplicits (map fst new_lhs_and_fv)+              implicit_uses = mkNameSet $ concatMap snd $ rec_uses         ; bindLocalNamesFV bound_names $           addLocalFixities fix_env bound_names $ do            -- (C) do the right-hand-sides and thing-inside         { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv         ; (res, fvs) <- cont segs+        ; mapM_ (\(loc, ns) -> checkUnusedRecordWildcard loc fvs (Just ns))+                rec_uses         ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses)         ; return (res, fvs) }} @@ -1119,23 +1094,23 @@                 -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]  rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b))-  = return [(L loc (BodyStmt noExt body a b), emptyFVs)]+  = return [(L loc (BodyStmt noExtField body a b), emptyFVs)]  rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a))-  = return [(L loc (LastStmt noExt body noret a), emptyFVs)]+  = return [(L loc (LastStmt noExtField body noret a), emptyFVs)]  rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body a b))   = do       -- should the ctxt be MDo instead?       (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat-      return [(L loc (BindStmt noExt pat' body a b), fv_pat)]+      return [(L loc (BindStmt noExtField pat' body a b), fv_pat)]  rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))))   = failWith (badIpBinds (text "an mdo expression") binds)  rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (L l (HsValBinds x binds))))     = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds-         return [(L loc (LetStmt noExt (L l (HsValBinds x binds'))),+         return [(L loc (LetStmt noExtField (L l (HsValBinds x binds'))),                  -- Warning: this is bogus; see function invariant                  emptyFVs                  )]@@ -1155,10 +1130,10 @@  rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))))   = panic "rn_rec_stmt LetStmt EmptyLocalBinds"-rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR _))))-  = panic "rn_rec_stmt LetStmt XHsLocalBindsLR"-rn_rec_stmt_lhs _ (L _ (XStmtLR _))-  = panic "rn_rec_stmt XStmtLR"+rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR nec))))+  = noExtCon nec+rn_rec_stmt_lhs _ (L _ (XStmtLR nec))+  = noExtCon nec  rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv                  -> [LStmt GhcPs body]@@ -1187,13 +1162,13 @@   = do  { (body', fv_expr) <- rnBody body         ; (ret_op, fvs1)   <- lookupSyntaxName returnMName         ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,-                   L loc (LastStmt noExt body' noret ret_op))] }+                   L loc (LastStmt noExtField body' noret ret_op))] }  rn_rec_stmt rnBody _ (L loc (BodyStmt _ body _ _), _)   = do { (body', fvs) <- rnBody body        ; (then_op, fvs1) <- lookupSyntaxName thenMName        ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,-                 L loc (BodyStmt noExt body' then_op noSyntaxExpr))] }+                 L loc (BodyStmt noExtField body' then_op noSyntaxExpr))] }  rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat)   = do { (body', fv_expr) <- rnBody body@@ -1204,7 +1179,7 @@        ; let bndrs = mkNameSet (collectPatBinders pat')              fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2        ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,-                  L loc (BindStmt noExt pat' body' bind_op fail_op))] }+                  L loc (BindStmt noExtField pat' body' bind_op fail_op))] }  rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _)   = failWith (badIpBinds (text "an mdo expression") binds)@@ -1214,7 +1189,7 @@            -- fixities and unused are handled above in rnRecStmtsAndThen        ; let fvs = allUses du_binds        ; return [(duDefs du_binds, fvs, emptyNameSet,-                 L loc (LetStmt noExt (L l (HsValBinds x binds'))))] }+                 L loc (LetStmt noExtField (L l (HsValBinds x binds'))))] }  -- no RecStmt case because they get flattened above when doing the LHSes rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _)@@ -1226,8 +1201,8 @@ rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _)     -- Syntactically illegal in mdo   = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) -rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR _))), _)-  = panic "rn_rec_stmt: LetStmt XHsLocalBindsLR"+rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR nec))), _)+  = noExtCon nec  rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _)   = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"@@ -1235,8 +1210,8 @@ rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _)   = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt) -rn_rec_stmt _ _ stmt@(L _ (XStmtLR {}), _)-  = pprPanic "rn_rec_stmt: XStmtLR" (ppr stmt)+rn_rec_stmt _ _ (L _ (XStmtLR nec), _)+  = noExtCon nec  rn_rec_stmts :: Outputable (body GhcPs) =>                 (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))@@ -1313,7 +1288,7 @@ ~~~~~~~~~~~~~~~~~~~~~ NB. June 7 2012: We only glom segments that appear in an explicit mdo; and leave those found in "do rec"'s intact.  See-http://ghc.haskell.org/trac/ghc/ticket/4148 for the discussion+https://gitlab.haskell.org/ghc/ghc/issues/4148 for the discussion leading to this design choice.  Hence the test in segmentRecStmts.  Note [Glomming segments]@@ -1521,12 +1496,45 @@      <*> ...      <*> argexpr(arg_n) += Relevant modules in the rest of the compiler =++ApplicativeDo touches a few phases in the compiler:++* Renamer: The journey begins here in the renamer, where do-blocks are+  scheduled as outlined above and transformed into applicative+  combinators.  However, the code is still represented as a do-block+  with special forms of applicative statements. This allows us to+  recover the original do-block when e.g. printing type errors, where+  we don't want to show any of the applicative combinators since they+  don't exist in the source code.+  See ApplicativeStmt and ApplicativeArg in HsExpr.++* Typechecker: ApplicativeDo passes through the typechecker much like any+  other form of expression. The only crux is that the typechecker has to+  be aware of the special ApplicativeDo statements in the do-notation, and+  typecheck them appropriately.+  Relevant module: TcMatches++* Desugarer: Any do-block which contains applicative statements is desugared+  as outlined above, to use the Applicative combinators.+  Relevant module: DsExpr+ -}  -- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and -- 'pureName' due to @RebindableSyntax@. data MonadNames = MonadNames { return_name, pure_name :: Name } +instance Outputable MonadNames where+  ppr (MonadNames {return_name=return_name,pure_name=pure_name}) =+    hcat+    [text "MonadNames { return_name = "+    ,ppr return_name+    ,text ", pure_name = "+    ,ppr pure_name+    ,text "}"+    ]+ -- | rearrange a list of statements using ApplicativeDoStmt.  See -- Note [ApplicativeDo]. rearrangeForApplicativeDo@@ -1669,16 +1677,27 @@ -- In the spec, but we do it here rather than in the desugarer, -- because we need the typechecker to typecheck the <$> form rather than -- the bind form, which would give rise to a Monad constraint.-stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ _), _))+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ fail_op), _))                 tail _tail_fvs   | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail   -- See Note [ApplicativeDo and strict patterns]-  = mkApplicativeStmt ctxt [ApplicativeArgOne noExt pat rhs False] False tail'+  = mkApplicativeStmt ctxt [ApplicativeArgOne+                            { xarg_app_arg_one = noExtField+                            , app_arg_pattern  = pat+                            , arg_expr         = rhs+                            , is_body_stmt     = False+                            , fail_operator    = fail_op}]+                      False tail' stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))                 tail _tail_fvs   | (False,tail') <- needJoin monad_names tail   = mkApplicativeStmt ctxt-      [ApplicativeArgOne noExt nlWildPatName rhs True] False tail'+      [ApplicativeArgOne+       { xarg_app_arg_one = noExtField+       , app_arg_pattern  = nlWildPatName+       , arg_expr         = rhs+       , is_body_stmt     = True+       , fail_operator    = noSyntaxExpr}] False tail'  stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =   return (s : tail, emptyNameSet)@@ -1692,14 +1711,31 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do    pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees    let (stmts', fvss) = unzip pairs-   let (need_join, tail') = needJoin monad_names tail+   let (need_join, tail') =+     -- See Note [ApplicativeDo and refutable patterns]+         if any hasRefutablePattern stmts'+         then (True, tail)+         else needJoin monad_names tail+    (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'    return (stmts, unionNameSets (fvs:fvss))  where-   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ _), _))-     = return (ApplicativeArgOne noExt pat exp False, emptyFVs)+   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ fail_op), _))+     = return (ApplicativeArgOne+               { xarg_app_arg_one = noExtField+               , app_arg_pattern  = pat+               , arg_expr         = exp+               , is_body_stmt     = False+               , fail_operator    = fail_op+               }, emptyFVs)    stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) =-     return (ApplicativeArgOne noExt nlWildPatName exp True, emptyFVs)+     return (ApplicativeArgOne+             { xarg_app_arg_one = noExtField+             , app_arg_pattern  = nlWildPatName+             , arg_expr         = exp+             , is_body_stmt     = True+             , fail_operator    = noSyntaxExpr+             }, emptyFVs)    stmtTreeArg ctxt tail_fvs tree = do      let stmts = flattenStmtTree tree          pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)@@ -1713,9 +1749,15 @@         if | L _ ApplicativeStmt{} <- last stmts' ->              return (unLoc tup, emptyNameSet)            | otherwise -> do-             (ret,fvs) <- lookupStmtNamePoly ctxt returnMName-             return (HsApp noExt (noLoc ret) tup, fvs)-     return ( ApplicativeArgMany noExt stmts' mb_ret pat+             ret <- lookupSyntaxName' returnMName+             let expr = HsApp noExtField (noLoc (HsVar noExtField (noLoc ret))) tup+             return (expr, emptyFVs)+     return ( ApplicativeArgMany+              { xarg_app_arg_many = noExtField+              , app_stmts         = stmts'+              , final_expr        = mb_ret+              , bv_pattern        = pat+              }             , fvs1 `plusFV` fvs2)  @@ -1819,6 +1861,20 @@     SplicePat{}     -> True     _otherwise -> panic "isStrictPattern" +{-+Note [ApplicativeDo and refutable patterns]++Refutable patterns in do blocks are desugared to use the monadic 'fail' operation.+This means that sometimes an applicative block needs to be wrapped in 'join' simply because+of a refutable pattern, in order for the types to work out.++-}++hasRefutablePattern :: ApplicativeArg GhcRn -> Bool+hasRefutablePattern (ApplicativeArgOne { app_arg_pattern = pat+                                       , is_body_stmt = False}) = not (isIrrefutableHsPat pat)+hasRefutablePattern _ = False+ isLetStmt :: LStmt a b -> Bool isLetStmt (L _ LetStmt{}) = True isLetStmt _ = False@@ -1858,7 +1914,7 @@   -- an infinite loop (#14163).   go lets indep bndrs ((L loc (BindStmt _ pat body bind_op fail_op), fvs): rest)     | isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat)-    = go lets ((L loc (BindStmt noExt pat body bind_op fail_op), fvs) : indep)+    = go lets ((L loc (BindStmt noExtField pat body bind_op fail_op), fvs) : indep)          bndrs' rest     where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)   -- If we encounter a LetStmt that doesn't depend on a BindStmt in this@@ -1866,9 +1922,9 @@   -- grouping more BindStmts.   -- TODO: perhaps we shouldn't do this if there are any strict bindings,   -- because we might be moving evaluation earlier.-  go lets indep bndrs ((L loc (LetStmt noExt binds), fvs) : rest)+  go lets indep bndrs ((L loc (LetStmt noExtField binds), fvs) : rest)     | isEmptyNameSet (bndrs `intersectNameSet` fvs)-    = go ((L loc (LetStmt noExt binds), fvs) : lets) indep bndrs rest+    = go ((L loc (LetStmt noExtField binds), fvs) : lets) indep bndrs rest   go _ []  _ _ = Nothing   go _ [_] _ _ = Nothing   go lets indep _ stmts = Just (reverse lets, reverse indep, stmts)@@ -1901,7 +1957,7 @@                 ; return (Just join_op, fvs) }            else              return (Nothing, emptyNameSet)-       ; let applicative_stmt = noLoc $ ApplicativeStmt noExt+       ; let applicative_stmt = noLoc $ ApplicativeStmt noExtField                (zip (fmap_op : repeat ap_op) args)                mb_join        ; return ( applicative_stmt : body_stmts@@ -1915,7 +1971,7 @@ needJoin _monad_names [] = (False, [])  -- we're in an ApplicativeArg needJoin monad_names  [L loc (LastStmt _ e _ t)]  | Just arg <- isReturnApp monad_names e =-       (False, [L loc (LastStmt noExt arg True t)])+       (False, [L loc (LastStmt noExtField arg True t)]) needJoin _monad_names stmts = (True, stmts)  -- | @Just e@, if the expression is @return e@ or @return $ e@,@@ -2004,7 +2060,7 @@    msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement")              , text "in" <+> pprAStmtContext ctxt ] -pprStmtCat :: Stmt a body -> SDoc+pprStmtCat :: Stmt (GhcPass a) body -> SDoc pprStmtCat (TransStmt {})     = text "transform" pprStmtCat (LastStmt {})      = text "return expression" pprStmtCat (BodyStmt {})      = text "body"@@ -2013,7 +2069,7 @@ pprStmtCat (RecStmt {})       = text "rec" pprStmtCat (ParStmt {})       = text "parallel" pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt"-pprStmtCat (XStmtLR {})         = panic "pprStmtCat: XStmtLR"+pprStmtCat (XStmtLR nec)        = noExtCon nec  ------------ emptyInvalid :: Validity  -- Payload is the empty document@@ -2079,7 +2135,7 @@        RecStmt {}  -> emptyInvalid        LastStmt {} -> emptyInvalid  -- Should not happen (dealt with by checkLastStmt)        ApplicativeStmt {} -> emptyInvalid-       XStmtLR{} -> panic "okCompStmt"+       XStmtLR nec -> noExtCon nec  --------- checkTupleSection :: [LHsTupArg GhcPs] -> RnM ()@@ -2095,12 +2151,6 @@   = hang (text "A section must be enclosed in parentheses")        2 (text "thus:" <+> (parens (ppr expr))) -patSynErr :: HsExpr GhcPs -> SDoc -> RnM (HsExpr GhcRn, FreeVars)-patSynErr e explanation = do { addErr (sep [text "Pattern syntax in expression context:",-                                nest 4 (ppr e)] $$-                                  explanation)-                 ; return (EWildPat noExt, emptyFVs) }- badIpBinds :: Outputable a => SDoc -> a -> SDoc badIpBinds what binds   = hang (text "Implicit-parameter bindings illegal in" <+> what)@@ -2166,7 +2216,7 @@                       (nlHsApp (noLoc $ syn_expr fromStringExpr)                                 (noLoc $ syn_expr arg_syn_expr))         let failAfterFromStringExpr :: HsExpr GhcRn =-              unLoc $ mkHsLam [noLoc $ VarPat noExt $ noLoc arg_name] body+              unLoc $ mkHsLam [noLoc $ VarPat noExtField $ noLoc arg_name] body         let failAfterFromStringSynExpr :: SyntaxExpr GhcRn =               mkSyntaxExpr failAfterFromStringExpr         return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)
compiler/rename/RnExpr.hs-boot view
@@ -1,6 +1,6 @@ module RnExpr where import Name-import HsSyn+import GHC.Hs import NameSet     ( FreeVars ) import TcRnTypes import SrcLoc      ( Located )
compiler/rename/RnFixity.hs view
@@ -14,7 +14,7 @@ import GhcPrelude  import LoadIface-import HsSyn+import GHC.Hs import RdrName import HscTypes import TcRnMonad@@ -124,7 +124,7 @@   = return (False, Fixity NoSourceText minPrecedence InfixL)     -- Minimise errors from ubound names; eg     --    a>0 `foo` b>0-    -- where 'foo' is not in scope, should not give an error (Trac #7937)+    -- where 'foo' is not in scope, should not give an error (#7937)    | otherwise   = do { local_fix_env <- getFixityEnv@@ -157,7 +157,7 @@       -- loadInterfaceForName will find B.hi even if B is a hidden module,       -- and that's what we want.       = do { iface <- loadInterfaceForName doc name-           ; let mb_fix = mi_fix_fn iface occ+           ; let mb_fix = mi_fix_fn (mi_final_exts iface) occ            ; let msg = case mb_fix of                             Nothing ->                                   text "looking up name" <+> ppr name@@ -178,7 +178,7 @@ -- | Look up the fixity of a (possibly ambiguous) occurrence of a record field -- selector.  We use 'lookupFixityRn'' so that we can specifiy the 'OccName' as -- the field label, which might be different to the 'OccName' of the selector--- 'Name' if @DuplicateRecordFields@ is in use (Trac #1173). If there are+-- 'Name' if @DuplicateRecordFields@ is in use (#1173). If there are -- multiple possible selectors with different fixities, generate an error. lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity lookupFieldFixityRn (Unambiguous n lrdr)@@ -211,4 +211,4 @@      format_ambig (elt, fix) = hang (ppr fix)                                  2 (pprNameProvenance elt)-lookupFieldFixityRn (XAmbiguousFieldOcc{}) = panic "lookupFieldFixityRn"+lookupFieldFixityRn (XAmbiguousFieldOcc nec) = noExtCon nec
compiler/rename/RnHsDoc.hs view
@@ -5,7 +5,7 @@ import GhcPrelude  import TcRnTypes-import HsSyn+import GHC.Hs import SrcLoc
compiler/rename/RnNames.hs view
@@ -27,12 +27,13 @@         ImportDeclUsage     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import DynFlags-import HsSyn+import TyCoPpr+import GHC.Hs import TcEnv import RnEnv import RnFixity@@ -239,7 +240,7 @@ if there's a lot of overlap in the imp_finsts of imports, the Set doesn't really need to grow and we don't need to allocate. -Running generateModules from Trac #14693 with DEPTH=16, WIDTH=30 finishes in+Running generateModules from #14693 with DEPTH=16, WIDTH=30 finishes in 23s before, and 11s after. -} @@ -263,11 +264,11 @@ rnImportDecl  :: Module -> LImportDecl GhcPs              -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImportDecl this_mod-             (L loc decl@(ImportDecl { ideclExt = noExt+             (L loc decl@(ImportDecl { ideclExt = noExtField                                      , ideclName = loc_imp_mod_name                                      , ideclPkgQual = mb_pkg                                      , ideclSource = want_boot, ideclSafe = mod_safe-                                     , ideclQualified = qual_only, ideclImplicit = implicit+                                     , ideclQualified = qual_style, ideclImplicit = implicit                                      , ideclAs = as_mod, ideclHiding = imp_details }))   = setSrcSpan loc $ do @@ -275,12 +276,14 @@         pkg_imports <- xoptM LangExt.PackageImports         when (not pkg_imports) $ addErr packageImportErr +    let qual_only = isImportDeclQualified qual_style+     -- If there's an error in loadInterface, (e.g. interface     -- file not found) we get lots of spurious errors from 'filterImports'     let imp_mod_name = unLoc loc_imp_mod_name         doc = ppr imp_mod_name <+> text "is directly imported" -    -- Check for self-import, which confuses the typechecker (Trac #9032)+    -- Check for self-import, which confuses the typechecker (#9032)     -- ghc --make rejects self-import cycles already, but batch-mode may not     -- at least not until TcIface.tcHiBootIface, which is too late to avoid     -- typechecker crashes.  (Indirect self imports are not caught until@@ -296,7 +299,7 @@           (case mb_pkg of  -- If we have import "<pkg>" M, then we should                            -- check that "<pkg>" is "this" (which is magic)                            -- or the name of this_mod's package.  Yurgh!-                           -- c.f. GHC.findModule, and Trac #9997+                           -- c.f. GHC.findModule, and #9997              Nothing         -> True              Just (StringLiteral _ pkg_fs) -> pkg_fs == fsLit "this" ||                             fsToUnitId pkg_fs == moduleUnitId this_mod))@@ -374,11 +377,14 @@           _           -> return ()      ) -    let new_imp_decl = L loc (decl { ideclExt = noExt, ideclSafe = mod_safe'+    -- Complain about -Wcompat-unqualified-imports violations.+    warnUnqualifiedImport decl iface++    let new_imp_decl = L loc (decl { ideclExt = noExtField, ideclSafe = mod_safe'                                    , ideclHiding = new_imp_details })      return (new_imp_decl, gbl_env, imports, mi_hpc iface)-rnImportDecl _ (L _ (XImportDecl _)) = panic "rnImportDecl"+rnImportDecl _ (L _ (XImportDecl nec)) = noExtCon nec  -- | Calculate the 'ImportAvails' induced by an import of a particular -- interface, but without 'imp_mods'.@@ -391,8 +397,8 @@ calculateAvails dflags iface mod_safe' want_boot imported_by =   let imp_mod    = mi_module iface       imp_sem_mod= mi_semantic_module iface-      orph_iface = mi_orphan iface-      has_finsts = mi_finsts iface+      orph_iface = mi_orphan (mi_final_exts iface)+      has_finsts = mi_finsts (mi_final_exts iface)       deps       = mi_deps iface       trust      = getSafeMode $ mi_trust iface       trust_pkg  = mi_trust_pkg iface@@ -481,6 +487,40 @@      }  +-- | Issue a warning if the user imports Data.List without either an import+-- list or `qualified`. This is part of the migration plan for the+-- `Data.List.singleton` proposal. See #17244.+warnUnqualifiedImport :: ImportDecl GhcPs -> ModIface -> RnM ()+warnUnqualifiedImport decl iface =+    whenWOptM Opt_WarnCompatUnqualifiedImports+    $ when bad_import+    $ addWarnAt (Reason Opt_WarnCompatUnqualifiedImports) loc warning+  where+    mod = mi_module iface+    loc = getLoc $ ideclName decl++    is_qual = isImportDeclQualified (ideclQualified decl)+    has_import_list =+      -- We treat a `hiding` clause as not having an import list although+      -- it's not entirely clear this is the right choice.+      case ideclHiding decl of+        Just (False, _) -> True+        _               -> False+    bad_import =+      mod `elemModuleSet` qualifiedMods+      && not is_qual+      && not has_import_list++    warning = vcat+      [ text "To ensure compatibility with future core libraries changes"+      , text "imports to" <+> ppr (ideclName decl) <+> text "should be"+      , text "either qualified or have an explicit import list."+      ]++    -- Modules for which we warn if we see unqualified imports+    qualifiedMods = mkModuleSet [ dATA_LIST ]++ warnRedundantSourceImport :: ModuleName -> SDoc warnRedundantSourceImport mod_name   = text "Unnecessary {-# SOURCE #-} in the import of module"@@ -605,7 +645,7 @@     getLocalDeclBindersd@ returns the names for an HsDecl              It's used for source code. -        *** See Note [The Naming story] in HsDecls ****+        *** See Note [The Naming story] in GHC.Hs.Decls **** *                                                                      * ********************************************************************* -} @@ -721,7 +761,7 @@           = expectJust "getLocalNonValBinders/find_con_decl_fld" $               find (\ fl -> flLabel fl == lbl) flds           where lbl = occNameFS (rdrNameOcc rdr)-        find_con_decl_fld (L _ (XFieldOcc _)) = panic "getLocalNonValBinders"+        find_con_decl_fld (L _ (XFieldOcc nec)) = noExtCon nec      new_assoc :: Bool -> LInstDecl GhcPs               -> RnM ([AvailInfo], [(Name, [FieldLabel])])@@ -733,16 +773,32 @@            ; return ([avail], flds) }     new_assoc overload_ok (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty                                                       , cid_datafam_insts = adts })))-      | Just (L loc cls_rdr) <- getLHsInstDeclClass_maybe inst_ty-      = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr-           ; (avails, fldss)-                    <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts-           ; return (avails, concat fldss) }-      | otherwise-      = return ([], [])    -- Do not crash on ill-formed instances-                           -- Eg   instance !Show Int   Trac #3811c-    new_assoc _ (L _ (ClsInstD _ (XClsInstDecl _))) = panic "new_assoc"-    new_assoc _ (L _ (XInstDecl _))                 = panic "new_assoc"+      = do -- First, attempt to grab the name of the class from the instance.+           -- This step could fail if the instance is not headed by a class,+           -- such as in the following examples:+           --+           -- (1) The class is headed by a bang pattern, such as in+           --     `instance !Show Int` (#3811c)+           -- (2) The class is headed by a type variable, such as in+           --     `instance c` (#16385)+           --+           -- If looking up the class name fails, then mb_cls_nm will+           -- be Nothing.+           mb_cls_nm <- runMaybeT $ do+             -- See (1) above+             L loc cls_rdr <- MaybeT $ pure $ getLHsInstDeclClass_maybe inst_ty+             -- See (2) above+             MaybeT $ setSrcSpan loc $ lookupGlobalOccRn_maybe cls_rdr+           -- Assuming the previous step succeeded, process any associated data+           -- family instances. If the previous step failed, bail out.+           case mb_cls_nm of+             Nothing -> pure ([], [])+             Just cls_nm -> do+               (avails, fldss)+                 <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts+               pure (avails, concat fldss)+    new_assoc _ (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec+    new_assoc _ (L _ (XInstDecl nec))                 = noExtCon nec      new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs                    -> RnM (AvailInfo, [(Name, [FieldLabel])])@@ -756,16 +812,16 @@                                   -- main_name is not bound here!                    fld_env  = mk_fld_env (feqn_rhs ti_decl) sub_names flds'              ; return (avail, fld_env) }-    new_di _ _ (DataFamInstDecl (XHsImplicitBndrs _)) = panic "new_di"+    new_di _ _ (DataFamInstDecl (XHsImplicitBndrs nec)) = noExtCon nec      new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs                    -> RnM (AvailInfo, [(Name, [FieldLabel])])     new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d-getLocalNonValBinders _ (XHsGroup _) = panic "getLocalNonValBinders"+getLocalNonValBinders _ (XHsGroup nec) = noExtCon nec  newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!"-newRecordSelector _ _ (L _ (XFieldOcc _)) = panic "newRecordSelector"+newRecordSelector _ _ (L _ (XFieldOcc nec)) = noExtCon nec newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld)))   = do { selName <- newTopSrcBinder $ L loc $ field        ; return $ qualFieldLbl { flSelector = selName } }@@ -889,7 +945,7 @@         -- 'combine' is only called for associated data types which appear         -- twice in the all_avails. In the example, we combine         --    T(T,T1,T2,T3) and C(C,T)  to give   (T, T(T,T1,T2,T3), Just C)-        -- NB: the AvailTC can have fields as well as data constructors (Trac #12127)+        -- NB: the AvailTC can have fields as well as data constructors (#12127)         combine (name1, a1@(AvailTC p1 _ _), mp1)                 (name2, a2@(AvailTC p2 _ _), mp2)           = ASSERT2( name1 == name2 && isNothing mp1 && isNothing mp2@@ -948,7 +1004,7 @@       case ie of         IEVar _ (L l n) -> do             (name, avail, _) <- lookup_name ie $ ieWrappedName n-            return ([(IEVar noExt (L l (replaceWrappedName n name)),+            return ([(IEVar noExtField (L l (replaceWrappedName n name)),                                                   trimAvail avail name)], [])          IEThingAll _ (L l tc) -> do@@ -967,7 +1023,7 @@                             | otherwise                             -> [] -                renamed_ie = IEThingAll noExt (L l (replaceWrappedName tc name))+                renamed_ie = IEThingAll noExtField (L l (replaceWrappedName tc name))                 sub_avails = case avail of                                Avail {}              -> []                                AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)]@@ -996,7 +1052,7 @@         IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns rdr_fs ->           ASSERT2(null rdr_fs, ppr rdr_fs) do            (name, avail, mb_parent)-               <- lookup_name (IEThingAbs noExt ltc) (ieWrappedName rdr_tc)+               <- lookup_name (IEThingAbs noExtField ltc) (ieWrappedName rdr_tc)             let (ns,subflds) = case avail of                                 AvailTC _ ns' subflds' -> (ns',subflds')@@ -1014,13 +1070,13 @@                                 -- We are trying to import T( a,b,c,d ), and failed                                 -- to find 'b' and 'd'.  So we make up an import item                                 -- to report as failing, namely T( b, d ).-                                -- c.f. Trac #15412+                                -- c.f. #15412               Succeeded (childnames, childflds) ->                case mb_parent of                  -- non-associated ty/cls                  Nothing-                   -> return ([(IEThingWith noExt (L l name') wc childnames'+                   -> return ([(IEThingWith noExtField (L l name') wc childnames'                                                                  childflds,                                AvailTC name (name:map unLoc childnames) (map unLoc childflds))],                               [])@@ -1029,10 +1085,10 @@                          -- childnames' = postrn_ies childnames                  -- associated ty                  Just parent-                   -> return ([(IEThingWith noExt (L l name') wc childnames'+                   -> return ([(IEThingWith noExtField (L l name') wc childnames'                                                            childflds,                                 AvailTC name (map unLoc childnames) (map unLoc childflds)),-                               (IEThingWith noExt (L l name') wc childnames'+                               (IEThingWith noExtField (L l name') wc childnames'                                                            childflds,                                 AvailTC parent [name] [])],                               [])@@ -1045,9 +1101,9 @@        where         mkIEThingAbs tc l (n, av, Nothing    )-          = (IEThingAbs noExt (L l (replaceWrappedName tc n)), trimAvail av n)+          = (IEThingAbs noExtField (L l (replaceWrappedName tc n)), trimAvail av n)         mkIEThingAbs tc l (n, _,  Just parent)-          = (IEThingAbs noExt (L l (replaceWrappedName tc n))+          = (IEThingAbs noExtField (L l (replaceWrappedName tc n))              , AvailTC parent [n] [])          handle_bad_import m = catchIELookup m $ \err -> case err of@@ -1172,16 +1228,16 @@ ********************************************************* -} -reportUnusedNames :: Maybe (Located [LIE GhcPs])  -- Export list-                  -> TcGblEnv -> RnM ()-reportUnusedNames _export_decls gbl_env-  = do  { traceRn "RUN" (ppr (tcg_dus gbl_env))+reportUnusedNames :: TcGblEnv -> RnM ()+reportUnusedNames gbl_env+  = do  { keep <- readTcRef (tcg_keep gbl_env)+        ; traceRn "RUN" (ppr (tcg_dus gbl_env))         ; warnUnusedImportDecls gbl_env-        ; warnUnusedTopBinds unused_locals+        ; warnUnusedTopBinds $ unused_locals keep         ; warnMissingSignatures gbl_env }   where-    used_names :: NameSet-    used_names = findUses (tcg_dus gbl_env) emptyNameSet+    used_names :: NameSet -> NameSet+    used_names keep = findUses (tcg_dus gbl_env) emptyNameSet `unionNameSet` keep     -- NB: currently, if f x = g, we only treat 'g' as used if 'f' is used     -- Hence findUses @@ -1189,13 +1245,6 @@     defined_names :: [GlobalRdrElt]     defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env) -    -- Note that defined_and_used, defined_but_not_used-    -- are both [GRE]; that's why we need defined_and_used-    -- rather than just used_names-    _defined_and_used, defined_but_not_used :: [GlobalRdrElt]-    (_defined_and_used, defined_but_not_used)-        = partition (gre_is_used used_names) defined_names-     kids_env = mkChildEnv defined_names     -- This is done in mkExports too; duplicated work @@ -1210,8 +1259,16 @@     --  (a) defined in this module, and     --  (b) not defined by a 'deriving' clause     -- The latter have an Internal Name, so we can filter them out easily-    unused_locals :: [GlobalRdrElt]-    unused_locals = filter is_unused_local defined_but_not_used+    unused_locals :: NameSet -> [GlobalRdrElt]+    unused_locals keep =+      let -- Note that defined_and_used, defined_but_not_used+          -- are both [GRE]; that's why we need defined_and_used+          -- rather than just used_names+          _defined_and_used, defined_but_not_used :: [GlobalRdrElt]+          (_defined_and_used, defined_but_not_used)+              = partition (gre_is_used (used_names keep)) defined_names++      in filter is_unused_local defined_but_not_used     is_unused_local :: GlobalRdrElt -> Bool     is_unused_local gre = isLocalGRE gre && isExternalName (gre_name gre) @@ -1287,7 +1344,7 @@  This code finds which import declarations are unused.  The specification and implementation notes are here:-  http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/UnusedImports+  https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/unused-imports  See also Note [Choosing the best import declaration] in RdrName -}@@ -1342,7 +1399,7 @@         used_names   = mkNameSet (map      gre_name        used_gres)         used_parents = mkNameSet (mapMaybe greParent_maybe used_gres) -        unused_imps   -- Not trivial; see eg Trac #7454+        unused_imps   -- Not trivial; see eg #7454           = case imps of               Just (False, L _ imp_ies) ->                                  foldr (add_unused . unLoc) emptyNameSet imp_ies@@ -1376,7 +1433,7 @@        -- If you use 'signum' from Num, then the user may well have        -- imported Num(signum).  We don't want to complain that        -- Num is not itself mentioned.  Hence the two cases in add_unused_with.-    unused_decl (L _ (XImportDecl _)) = panic "unused_decl"+    unused_decl (L _ (XImportDecl nec)) = noExtCon nec   {- Note [The ImportMap]@@ -1387,7 +1444,7 @@  The SrcLoc is the location of the END of a particular 'import' declaration.  Why *END*?  Because we don't want to get confused-by the implicit Prelude import. Consider (Trac #7476) the module+by the implicit Prelude import. Consider (#7476) the module     import Foo( foo )     main = print foo There is an implicit 'import Prelude(print)', and it gets a SrcSpan@@ -1454,8 +1511,8 @@                , text "from module" <+> quotes pp_mod <+> is_redundant]     pp_herald  = text "The" <+> pp_qual <+> text "import of"     pp_qual-      | ideclQualified decl = text "qualified"-      | otherwise           = Outputable.empty+      | isImportDeclQualified (ideclQualified decl)= text "qualified"+      | otherwise                                  = Outputable.empty     pp_mod       = ppr (unLoc (ideclName decl))     is_redundant = text "is redundant" @@ -1477,7 +1534,7 @@ We do not warn about    import Prelude hiding( x, y ) because even if nothing else from Prelude is used, it may be essential to hide-x,y to avoid name-shadowing warnings.  Example (Trac #9061)+x,y to avoid name-shadowing warnings.  Example (#9061)    import Prelude hiding( log )    f x = log where log = () @@ -1517,25 +1574,25 @@     -- we want to say "T(..)", but if we're importing only a subset we want     -- to say "T(A,B,C)".  So we have to find out what the module exports.     to_ie _ (Avail n)-       = [IEVar noExt (to_ie_post_rn $ noLoc n)]+       = [IEVar noExtField (to_ie_post_rn $ noLoc n)]     to_ie _ (AvailTC n [m] [])-       | n==m = [IEThingAbs noExt (to_ie_post_rn $ noLoc n)]+       | n==m = [IEThingAbs noExtField (to_ie_post_rn $ noLoc n)]     to_ie iface (AvailTC n ns fs)       = case [(xs,gs) |  AvailTC x xs gs <- mi_exports iface                  , x == n                  , x `elem` xs    -- Note [Partial export]                  ] of-           [xs] | all_used xs -> [IEThingAll noExt (to_ie_post_rn $ noLoc n)]+           [xs] | all_used xs -> [IEThingAll noExtField (to_ie_post_rn $ noLoc n)]                 | otherwise   ->-                   [IEThingWith noExt (to_ie_post_rn $ noLoc n) NoIEWildcard+                   [IEThingWith noExtField (to_ie_post_rn $ noLoc n) NoIEWildcard                                 (map (to_ie_post_rn . noLoc) (filter (/= n) ns))                                 (map noLoc fs)]                                           -- Note [Overloaded field import]            _other | all_non_overloaded fs-                           -> map (IEVar noExt . to_ie_post_rn_var . noLoc) $ ns+                           -> map (IEVar noExtField . to_ie_post_rn_var . noLoc) $ ns                                  ++ map flSelector fs                   | otherwise ->-                      [IEThingWith noExt (to_ie_post_rn $ noLoc n) NoIEWildcard+                      [IEThingWith noExtField (to_ie_post_rn $ noLoc n) NoIEWildcard                                 (map (to_ie_post_rn . noLoc) (filter (/= n) ns))                                 (map noLoc fs)]         where@@ -1700,7 +1757,7 @@           text "but it has none" ]  dodgyMsgInsert :: forall p . IdP (GhcPass p) -> IE (GhcPass p)-dodgyMsgInsert tc = IEThingAll noExt ii+dodgyMsgInsert tc = IEThingAll noExtField ii   where     ii :: LIEWrappedName (IdP (GhcPass p))     ii = noLoc (IEName $ noLoc tc)
compiler/rename/RnPat.hs view
@@ -16,6 +16,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveFunctor #-}  module RnPat (-- main entry points               rnPat, rnPats, rnBindPat, rnPatAndThen,@@ -45,15 +46,16 @@ import {-# SOURCE #-} RnExpr ( rnLExpr ) import {-# SOURCE #-} RnSplice ( rnSplicePat ) -#include "GhclibHsVersions.h"+#include "HsVersions.h" -import HsSyn+import GHC.Hs import TcRnMonad import TcHsSyn             ( hsOverLitName ) import RnEnv import RnFixity import RnUtils             ( HsDocContext(..), newLocalBndrRn, bindLocalNames                            , warnUnusedMatches, newLocalBndrRn+                           , checkUnusedRecordWildcard                            , checkDupNames, checkDupAndShadowedNames                            , checkTupSize , unknownSubordinateErr ) import RnTypes@@ -71,7 +73,7 @@ import DataCon import qualified GHC.LanguageExtensions as LangExt -import Control.Monad       ( when, liftM, ap, guard )+import Control.Monad       ( when, ap, guard ) import qualified Data.List.NonEmpty as NE import Data.Ratio @@ -106,11 +108,9 @@  newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars))                                             -> RnM (r, FreeVars) }+        deriving (Functor)         -- See Note [CpsRn monad] -instance Functor CpsRn where-    fmap = liftM- instance Applicative CpsRn where     pure x = CpsRn (\k -> k x)     (<*>) = ap@@ -159,7 +159,7 @@  Arguably we should report T2 as unused, even though it appears in a pattern, because it never occurs in a constructed position.  See-Trac #7336.+#7336. However, implementing this in the face of pattern synonyms would be less straightforward, since given two pattern synonyms @@ -257,7 +257,7 @@ Here the pattern binds 'r', and then uses it *only* in the view pattern. We want to "see" this use, and in let-bindings we collect all uses and report unused variables at the binding level. So we must use bindLocalNames-here, *not* bindLocalNameFV.  Trac #3943.+here, *not* bindLocalNameFV.  #3943.   Note [Don't report shadowing for pattern synonyms]@@ -319,7 +319,7 @@         ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do         { -- Check for duplicated and shadowed names           -- Must do this *after* renaming the patterns-          -- See Note [Collect binders only after renaming] in HsUtils+          -- See Note [Collect binders only after renaming] in GHC.Hs.Utils           -- Because we don't bind the vars all at once, we can't           --    check incrementally for duplicates;           -- Nor can we check incrementally for shadowing, else we'll@@ -384,7 +384,7 @@ rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat  rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn)-rnPatAndThen _  (WildPat _)   = return (WildPat noExt)+rnPatAndThen _  (WildPat _)   = return (WildPat noExtField) rnPatAndThen mk (ParPat x pat)  = do { pat' <- rnLPatAndThen mk pat                                      ; return (ParPat x pat') } rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat@@ -471,7 +471,7 @@    -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on.   = case unLoc con == nameRdrName (dataConName nilDataCon) of       True    -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists-                    ; if ol_flag then rnPatAndThen mk (ListPat noExt [])+                    ; if ol_flag then rnPatAndThen mk (ListPat noExtField [])                                  else rnConPatAndThen mk con stuff}       False   -> rnConPatAndThen mk con stuff @@ -529,6 +529,12 @@         ; rpats' <- rnHsRecPatsAndThen mk con' rpats         ; return (ConPatIn con' (RecCon rpats')) } +checkUnusedRecordWildcardCps :: SrcSpan -> Maybe [Name] -> CpsRn ()+checkUnusedRecordWildcardCps loc dotdot_names =+  CpsRn (\thing -> do+                    (r, fvs) <- thing ()+                    checkUnusedRecordWildcard loc fvs dotdot_names+                    return (r, fvs) ) -------------------- rnHsRecPatsAndThen :: NameMaker                    -> Located Name      -- Constructor@@ -539,17 +545,31 @@   = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat                                             hs_rec_fields        ; flds' <- mapM rn_field (flds `zip` [1..])+       ; check_unused_wildcard (implicit_binders flds' <$> dd)        ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }   where-    mkVarPat l n = VarPat noExt (cL l n)+    mkVarPat l n = VarPat noExtField (cL l n)     rn_field (dL->L l fld, n') =       do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld)          ; return (cL l (fld { hsRecFieldArg = arg' })) } +    loc = maybe noSrcSpan getLoc dd++    -- Get the arguments of the implicit binders+    implicit_binders fs (unLoc -> n) = collectPatsBinders implicit_pats+      where+        implicit_pats = map (hsRecFieldArg . unLoc) (drop n fs)++    -- Don't warn for let P{..} = ... in ...+    check_unused_wildcard = case mk of+                              LetMk{} -> const (return ())+                              LamMk{} -> checkUnusedRecordWildcardCps loc+         -- Suppress unused-match reporting for fields introduced by ".."     nested_mk Nothing  mk                    _  = mk     nested_mk (Just _) mk@(LetMk {})         _  = mk-    nested_mk (Just n) (LamMk report_unused) n' = LamMk (report_unused && (n' <= n))+    nested_mk (Just (unLoc -> n)) (LamMk report_unused) n'+      = LamMk (report_unused && (n' <= n))  {- ************************************************************************@@ -622,19 +642,18 @@                                 -- due to #15884  -    rn_dotdot :: Maybe Int      -- See Note [DotDot fields] in HsPat+    rn_dotdot :: Maybe (Located Int)      -- See Note [DotDot fields] in GHC.Hs.Pat               -> Maybe Name -- The constructor (Nothing for an                                 --    out of scope constructor)               -> [LHsRecField GhcRn arg] -- Explicit fields-              -> RnM [LHsRecField GhcRn arg]   -- Filled in .. fields-    rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match+              -> RnM ([LHsRecField GhcRn arg])   -- Field Labels we need to fill in+    rn_dotdot (Just (dL -> L loc n)) (Just con) flds -- ".." on record construction / pat match       | not (isUnboundName con) -- This test is because if the constructor                                 -- isn't in scope the constructor lookup will add                                 -- an error but still return an unbound name. We                                 -- don't want that to screw up the dot-dot fill-in stuff.       = ASSERT( flds `lengthIs` n )-        do { loc <- getSrcSpanM -- Rather approximate-           ; dd_flag <- xoptM LangExt.RecordWildCards+        do { dd_flag <- xoptM LangExt.RecordWildCards            ; checkErr dd_flag (needFlagDotDot ctxt)            ; (rdr_env, lcl_env) <- getRdrEnvs            ; con_fields <- lookupConstructorFields con@@ -728,7 +747,7 @@                      then do { checkErr pun_ok (badPun (cL loc lbl))                                -- Discard any module qualifier (#11662)                              ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)-                             ; return (cL loc (HsVar noExt (cL loc arg_rdr))) }+                             ; return (cL loc (HsVar noExtField (cL loc arg_rdr))) }                      else return arg            ; (arg'', fvs) <- rnLExpr arg' @@ -738,10 +757,10 @@                           Right _       -> fvs                  lbl' = case sel of                           Left sel_name ->-                                     cL loc (Unambiguous sel_name  (cL loc lbl))+                                     cL loc (Unambiguous sel_name   (cL loc lbl))                           Right [sel_name] ->-                                     cL loc (Unambiguous sel_name  (cL loc lbl))-                          Right _ -> cL loc (Ambiguous   noExt     (cL loc lbl))+                                     cL loc (Unambiguous sel_name   (cL loc lbl))+                          Right _ -> cL loc (Ambiguous   noExtField (cL loc lbl))             ; return (cL l (HsRecField { hsRecFieldLbl = lbl'                                       , hsRecFieldArg = arg''@@ -833,7 +852,7 @@ zero value. So we had to add explicit field 'neg' which would hold information about literal sign. Here in rnOverLit we use it to detect negative zeroes and in this case return not only literal itself but also negateName so that users-can apply it explicitly. In this case it stays negative zero.  Trac #13211+can apply it explicitly. In this case it stays negative zero.  #13211 -}  rnOverLit :: HsOverLit t ->
compiler/rename/RnSource.hs view
@@ -14,14 +14,14 @@         rnSrcDecls, addTcgDUs, findSplice     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import {-# SOURCE #-} RnExpr( rnLExpr ) import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls ) -import HsSyn+import GHC.Hs import FieldLabel import RdrName import RnTypes@@ -52,7 +52,7 @@ import Avail import Outputable import Bag-import BasicTypes       ( pprRuleName )+import BasicTypes       ( pprRuleName, TypeOrKind(..) ) import FastString import SrcLoc import DynFlags@@ -62,6 +62,7 @@ import Digraph          ( SCC, flattenSCC, flattenSCCs, Node(..)                         , stronglyConnCompFromEdgedVerticesUniq ) import UniqSet+import OrdList import qualified GHC.LanguageExtensions as LangExt  import Control.Monad@@ -69,8 +70,9 @@ import Data.List ( mapAccumL ) import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty ( NonEmpty(..) )-import Data.Maybe ( isNothing, fromMaybe )+import Data.Maybe ( isNothing, fromMaybe, mapMaybe ) import qualified Data.Set as Set ( difference, fromList, toList, null )+import Data.Function ( on )  {- | @rnSourceDecl@ "renames" declarations. It simultaneously performs dependency analysis and precedence parsing.@@ -126,7 +128,7 @@     -- (D1) Bring pattern synonyms into scope.    --      Need to do this before (D2) because rnTopBindsLHS-   --      looks up those pattern synonyms (Trac #9889)+   --      looks up those pattern synonyms (#9889)     extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do { @@ -197,7 +199,7 @@     last_tcg_env <- getGblEnv ;    -- (I) Compute the results and return-   let {rn_group = HsGroup { hs_ext     = noExt,+   let {rn_group = HsGroup { hs_ext     = noExtField,                              hs_valds   = rn_val_decls,                              hs_splcds  = rn_splice_decls,                              hs_tyclds  = rn_tycl_decls,@@ -217,7 +219,7 @@                               src_fvs5, src_fvs6, src_fvs7] ;                 -- It is tiresome to gather the binders from type and class decls -        src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;+        src_dus = unitOL other_def `plusDU` bind_dus `plusDU` usesOnly other_fvs ;                 -- Instance decls may have occurrences of things bound in bind_dus                 -- so we must put other_fvs last @@ -229,7 +231,7 @@    traceRn "finish Dus" (ppr src_dus ) ;    return (final_tcg_env, rn_group)                     }}}}-rnSrcDecls (XHsGroup _) = panic "rnSrcDecls"+rnSrcDecls (XHsGroup nec) = noExtCon nec  addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv -- This function could be defined lower down in the module hierarchy,@@ -297,7 +299,7 @@      = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)                                 rdr_names           ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }-   rn_deprec (XWarnDecl _) = panic "rnSrcWarnDecls"+   rn_deprec (XWarnDecl nec) = noExtCon nec     what = text "deprecation" @@ -331,9 +333,9 @@     do { (provenance', provenance_fvs) <- rnAnnProvenance provenance        ; (expr', expr_fvs) <- setStage (Splice Untyped) $                               rnLExpr expr-       ; return (HsAnnotation noExt s provenance' expr',+       ; return (HsAnnotation noExtField s provenance' expr',                  provenance_fvs `plusFV` expr_fvs) }-rnAnnDecl (XAnnDecl _) = panic "rnAnnDecl"+rnAnnDecl (XAnnDecl nec) = noExtCon nec  rnAnnProvenance :: AnnProvenance RdrName                 -> RnM (AnnProvenance Name, FreeVars)@@ -352,10 +354,10 @@ rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars) rnDefaultDecl (DefaultDecl _ tys)   = do { (tys', fvs) <- rnLHsTypes doc_str tys-       ; return (DefaultDecl noExt tys', fvs) }+       ; return (DefaultDecl noExtField tys', fvs) }   where     doc_str = DefaultDeclCtx-rnDefaultDecl (XDefaultDecl _) = panic "rnDefaultDecl"+rnDefaultDecl (XDefaultDecl nec) = noExtCon nec  {- *********************************************************@@ -369,20 +371,20 @@ rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })   = do { topEnv :: HscEnv <- getTopEnv        ; name' <- lookupLocatedTopBndrRn name-       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty+       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty          -- Mark any PackageTarget style imports as coming from the current package        ; let unitId = thisPackage $ hsc_dflags topEnv              spec'      = patchForeignImport unitId spec -       ; return (ForeignImport { fd_i_ext = noExt+       ; return (ForeignImport { fd_i_ext = noExtField                                , fd_name = name', fd_sig_ty = ty'                                , fd_fi = spec' }, fvs) }  rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })   = do { name' <- lookupLocatedOccRn name-       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty-       ; return (ForeignExport { fd_e_ext = noExt+       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty+       ; return (ForeignExport { fd_e_ext = noExtField                                , fd_name = name', fd_sig_ty = ty'                                , fd_fe = spec }                 , fvs `addOneFV` unLoc name') }@@ -390,7 +392,7 @@         --     we add it to the free-variable list.  It might, for example,         --     be imported from another module -rnHsForeignDecl (XForeignDecl _) = panic "rnHsForeignDecl"+rnHsForeignDecl (XForeignDecl nec) = noExtCon nec  -- | For Windows DLLs we need to know what packages imported symbols are from --      to generate correct calls. Imported symbols are tagged with the current@@ -424,20 +426,20 @@  rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars) rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })-  = do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi-       ; return (TyFamInstD { tfid_ext = noExt, tfid_inst = tfi' }, fvs) }+  = do { (tfi', fvs) <- rnTyFamInstDecl NonAssocTyFamEqn tfi+       ; return (TyFamInstD { tfid_ext = noExtField, tfid_inst = tfi' }, fvs) }  rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })-  = do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi-       ; return (DataFamInstD { dfid_ext = noExt, dfid_inst = dfi' }, fvs) }+  = do { (dfi', fvs) <- rnDataFamInstDecl NonAssocTyFamEqn dfi+       ; return (DataFamInstD { dfid_ext = noExtField, dfid_inst = dfi' }, fvs) }  rnSrcInstDecl (ClsInstD { cid_inst = cid })   = do { traceRn "rnSrcIstDecl {" (ppr cid)        ; (cid', fvs) <- rnClsInstDecl cid        ; traceRn "rnSrcIstDecl end }" empty-       ; return (ClsInstD { cid_d_ext = noExt, cid_inst = cid' }, fvs) }+       ; return (ClsInstD { cid_d_ext = noExtField, cid_inst = cid' }, fvs) } -rnSrcInstDecl (XInstDecl _) = panic "rnSrcInstDecl"+rnSrcInstDecl (XInstDecl nec) = noExtCon nec  -- | Warn about non-canonical typeclass instance declarations --@@ -606,7 +608,7 @@                            , cid_overlap_mode = oflag                            , cid_datafam_insts = adts })   = do { (inst_ty', inst_fvs)-           <- rnHsSigType (GenericCtx $ text "an instance declaration") inst_ty+           <- rnHsSigType (GenericCtx $ text "an instance declaration") TypeLevel inst_ty        ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'        ; cls <-            case hsTyGetAppHead_maybe head_ty' of@@ -617,7 +619,7 @@                -- we report an error and continue for as long as we can.                -- Importantly, this error should be thrown before we reach the                -- typechecker, lest we encounter different errors that are-               -- hopelessly confusing (such as the one in Trac #16114).+               -- hopelessly confusing (such as the one in #16114).                addErrAt (getLoc (hsSigType inst_ty)) $                  hang (text "Illegal class instance:" <+> quotes (ppr inst_ty))                     2 (vcat [ text "Class instances must be of the form"@@ -647,7 +649,7 @@         ; let all_fvs = meth_fvs `plusFV` more_fvs                                 `plusFV` inst_fvs-       ; return (ClsInstDecl { cid_ext = noExt+       ; return (ClsInstDecl { cid_ext = noExtField                              , cid_poly_ty = inst_ty', cid_binds = mbinds'                              , cid_sigs = uprags', cid_tyfam_insts = ats'                              , cid_overlap_mode = oflag@@ -663,36 +665,33 @@              --     the instance context after renaming.  This is a bit              --     strange, but should not matter (and it would be more work              --     to remove the context).-rnClsInstDecl (XClsInstDecl _) = panic "rnClsInstDecl"+rnClsInstDecl (XClsInstDecl nec) = noExtCon nec  rnFamInstEqn :: HsDocContext-             -> Maybe (Name, [Name]) -- Nothing => not associated-                                     -- Just (cls,tvs) => associated,-                                     --   and gives class and tyvars of the-                                     --   parent instance decl+             -> AssocTyFamInfo              -> [Located RdrName]    -- Kind variables from the equation's RHS              -> FamInstEqn GhcPs rhs              -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))              -> RnM (FamInstEqn GhcRn rhs', FreeVars)-rnFamInstEqn doc mb_cls rhs_kvars+rnFamInstEqn doc atfi rhs_kvars     (HsIB { hsib_body = FamEqn { feqn_tycon  = tycon                                , feqn_bndrs  = mb_bndrs                                , feqn_pats   = pats                                , feqn_fixity = fixity                                , feqn_rhs    = payload }}) rn_payload-  = do { tycon'   <- lookupFamInstName (fmap fst mb_cls) tycon+  = do { let mb_cls = case atfi of+                        NonAssocTyFamEqn     -> Nothing+                        AssocTyFamDeflt cls  -> Just cls+                        AssocTyFamInst cls _ -> Just cls+       ; tycon'   <- lookupFamInstName mb_cls tycon        ; let pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVarsDup pats              -- Use the "...Dups" form because it's needed              -- below to report unsed binder on the LHS-       ; let pat_kity_vars = rmDupsInRdrTyVars pat_kity_vars_with_dups -         -- all pat vars not explicitly bound (see extractHsTvBndrs)-       ; let mb_imp_kity_vars = extractHsTvBndrs <$> mb_bndrs <*> pure pat_kity_vars-             imp_vars = case mb_imp_kity_vars of-                          -- kind vars are the only ones free if we have an explicit forall-                          Just nbnd_kity_vars -> freeKiTyVarsKindVars nbnd_kity_vars-                          -- all pattern vars are free otherwise-                          Nothing             -> freeKiTyVarsAllVars pat_kity_vars+         -- Implicitly bound variables, empty if we have an explicit 'forall' according+         -- to the "forall-or-nothing" rule.+       ; let imp_vars | isNothing mb_bndrs = nubL pat_kity_vars_with_dups+                      | otherwise = []        ; imp_var_names <- mapM (newTyVarNameRn mb_cls) imp_vars         ; let bndrs = fromMaybe [] mb_bndrs@@ -723,7 +722,7 @@                        -- See Note [Unused type variables in family instances]                     ; let groups :: [NonEmpty (Located RdrName)]                           groups = equivClasses cmpLocated $-                                   freeKiTyVarsAllVars pat_kity_vars_with_dups+                                   pat_kity_vars_with_dups                     ; nms_dups <- mapM (lookupOccRn . unLoc) $                                      [ tv | (tv :| (_:_)) <- groups ]                           -- Add to the used variables@@ -734,11 +733,11 @@                           --     Note [Unused type variables in family instances]                     ; let nms_used = extendNameSetList rhs_fvs $                                         inst_tvs ++ nms_dups-                          inst_tvs = case mb_cls of-                                       Nothing            -> []-                                       Just (_, inst_tvs) -> inst_tvs-                          all_nms = all_imp_var_names-                                      ++ map hsLTyVarName bndrs'+                          inst_tvs = case atfi of+                                       NonAssocTyFamEqn          -> []+                                       AssocTyFamDeflt _         -> []+                                       AssocTyFamInst _ inst_tvs -> inst_tvs+                          all_nms = all_imp_var_names ++ hsLTyVarNames bndrs'                     ; warnUnusedTypePatterns all_nms nms_used                      ; return ((bndrs', pats', payload'), rhs_fvs `plusFV` pat_fvs) }@@ -748,25 +747,37 @@         ; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances]                       , hsib_body-                          = FamEqn { feqn_ext    = noExt+                          = FamEqn { feqn_ext    = noExtField                                    , feqn_tycon  = tycon'                                    , feqn_bndrs  = bndrs' <$ mb_bndrs                                    , feqn_pats   = pats'                                    , feqn_fixity = fixity                                    , feqn_rhs    = payload' } },                  all_fvs) }-rnFamInstEqn _ _ _ (HsIB _ (XFamEqn _)) _ = panic "rnFamInstEqn"-rnFamInstEqn _ _ _ (XHsImplicitBndrs _) _ = panic "rnFamInstEqn"+rnFamInstEqn _ _ _ (HsIB _ (XFamEqn nec)) _ = noExtCon nec+rnFamInstEqn _ _ _ (XHsImplicitBndrs nec) _ = noExtCon nec -rnTyFamInstDecl :: Maybe (Name, [Name]) -- Just (cls,tvs) => associated,-                                        --   and gives class and tyvars of-                                        --   the parent instance decl+rnTyFamInstDecl :: AssocTyFamInfo                 -> TyFamInstDecl GhcPs                 -> RnM (TyFamInstDecl GhcRn, FreeVars)-rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = eqn })-  = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls NotClosedTyFam eqn+rnTyFamInstDecl atfi (TyFamInstDecl { tfid_eqn = eqn })+  = do { (eqn', fvs) <- rnTyFamInstEqn atfi NotClosedTyFam eqn        ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) } +-- | Tracks whether we are renaming:+--+-- 1. A type family equation that is not associated+--    with a parent type class ('NonAssocTyFamEqn')+--+-- 2. An associated type family default delcaration ('AssocTyFamDeflt')+--+-- 3. An associated type family instance declaration ('AssocTyFamInst')+data AssocTyFamInfo+  = NonAssocTyFamEqn+  | AssocTyFamDeflt Name   -- Name of the parent class+  | AssocTyFamInst  Name   -- Name of the parent class+                    [Name] -- Names of the tyvars of the parent instance decl+ -- | Tracks whether we are renaming an equation in a closed type family -- equation ('ClosedTyFam') or not ('NotClosedTyFam'). data ClosedTyFamInfo@@ -774,17 +785,17 @@   | ClosedTyFam (Located RdrName) Name                 -- The names (RdrName and Name) of the closed type family -rnTyFamInstEqn :: Maybe (Name, [Name])+rnTyFamInstEqn :: AssocTyFamInfo                -> ClosedTyFamInfo                -> TyFamInstEqn GhcPs                -> RnM (TyFamInstEqn GhcRn, FreeVars)-rnTyFamInstEqn mb_cls ctf_info+rnTyFamInstEqn atfi ctf_info     eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon                                    , feqn_rhs   = rhs }})   = do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs        ; (eqn'@(HsIB { hsib_body =                        FamEqn { feqn_tycon = dL -> L _ tycon' }}), fvs)-           <- rnFamInstEqn (TySynCtx tycon) mb_cls rhs_kvs eqn rnTySyn+           <- rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn        ; case ctf_info of            NotClosedTyFam -> pure ()            ClosedTyFam fam_rdr_name fam_name ->@@ -792,46 +803,28 @@              withHsDocContext (TyFamilyCtx fam_rdr_name) $              wrongTyFamName fam_name tycon'        ; pure (eqn', fvs) }-rnTyFamInstEqn _ _ (HsIB _ (XFamEqn _)) = panic "rnTyFamInstEqn"-rnTyFamInstEqn _ _ (XHsImplicitBndrs _) = panic "rnTyFamInstEqn"+rnTyFamInstEqn _ _ (HsIB _ (XFamEqn nec)) = noExtCon nec+rnTyFamInstEqn _ _ (XHsImplicitBndrs nec) = noExtCon nec -rnTyFamDefltEqn :: Name-                -> TyFamDefltEqn GhcPs-                -> RnM (TyFamDefltEqn GhcRn, FreeVars)-rnTyFamDefltEqn cls (FamEqn { feqn_tycon  = tycon-                            , feqn_bndrs  = bndrs-                            , feqn_pats   = tyvars-                            , feqn_fixity = fixity-                            , feqn_rhs    = rhs })-  = do { let kvs = extractHsTyRdrTyVarsKindVars rhs-       ; bindHsQTyVars ctx Nothing (Just cls) kvs tyvars $ \ tyvars' _ ->-    do { tycon'      <- lookupFamInstName (Just cls) tycon-       ; (rhs', fvs) <- rnLHsType ctx rhs-       ; return (FamEqn { feqn_ext    = noExt-                        , feqn_tycon  = tycon'-                        , feqn_bndrs  = ASSERT( isNothing bndrs )-                                        Nothing-                        , feqn_pats   = tyvars'-                        , feqn_fixity = fixity-                        , feqn_rhs    = rhs' }, fvs) } }-  where-    ctx = TyFamilyCtx tycon-rnTyFamDefltEqn _ (XFamEqn _) = panic "rnTyFamDefltEqn"+rnTyFamDefltDecl :: Name+                 -> TyFamDefltDecl GhcPs+                 -> RnM (TyFamDefltDecl GhcRn, FreeVars)+rnTyFamDefltDecl cls = rnTyFamInstDecl (AssocTyFamDeflt cls) -rnDataFamInstDecl :: Maybe (Name, [Name])+rnDataFamInstDecl :: AssocTyFamInfo                   -> DataFamInstDecl GhcPs                   -> RnM (DataFamInstDecl GhcRn, FreeVars)-rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =-                           FamEqn { feqn_tycon = tycon-                                  , feqn_rhs   = rhs }})})+rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =+                         FamEqn { feqn_tycon = tycon+                                , feqn_rhs   = rhs }})})   = do { let rhs_kvs = extractDataDefnKindVars rhs        ; (eqn', fvs) <--           rnFamInstEqn (TyDataCtx tycon) mb_cls rhs_kvs eqn rnDataDefn+           rnFamInstEqn (TyDataCtx tycon) atfi rhs_kvs eqn rnDataDefn        ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }-rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn _)))-  = panic "rnDataFamInstDecl"-rnDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs _))-  = panic "rnDataFamInstDecl"+rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn nec)))+  = noExtCon nec+rnDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs nec))+  = noExtCon nec  -- Renaming of the associated types in instances. @@ -842,8 +835,8 @@ rnATDecls cls at_decls   = rnList (rnFamDecl (Just cls)) at_decls -rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames-                  decl GhcPs ->            -- an instance. rnTyFamInstDecl+rnATInstDecls :: (AssocTyFamInfo ->           -- The function that renames+                  decl GhcPs ->               -- an instance. rnTyFamInstDecl                   RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl               -> Name      -- Class               -> [Name]@@ -855,7 +848,7 @@ -- NB: We allow duplicate associated-type decls; --     See Note [Associated type instances] in TcInstDcls rnATInstDecls rnFun cls tv_ns at_insts-  = rnList (rnFun (Just (cls, tv_ns))) at_insts+  = rnList (rnFun (AssocTyFamInst cls tv_ns)) at_insts     -- See Note [Renaming associated types]  {- Note [Wildcards in family instances]@@ -917,7 +910,7 @@       type F a x :: *    instance C (p,q) r where       type F (p,q) x = (x, r)   -- BAD: mentions 'r'-c.f. Trac #5515+c.f. #5515  Kind variables, on the other hand, are allowed to be implicitly or explicitly bound. As examples, this (#9574) is acceptable:@@ -942,7 +935,7 @@  All this applies only for *instance* declarations.  In *class* declarations there is no RHS to worry about, and the class variables-can all be in scope (Trac #5862):+can all be in scope (#5862):     class Category (x :: k -> k -> *) where       type Ob x :: k -> Constraint       id :: Ob x a => x a a@@ -959,7 +952,7 @@      type forall b. T (Maybe a) b = Either a b  Even though `a` is not bound by the forall, this is still accepted because `a`-was previously bound by the `instance C (Maybe a)` part. (see Trac #16116).+was previously bound by the `instance C (Maybe a)` part. (see #16116).  In each case, the function which detects improperly bound variables on the RHS is TcValidity.checkValidFamPats.@@ -979,14 +972,13 @@   = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving        ; unless standalone_deriv_ok (addErr standaloneDerivErr)        ; (mds', ty', fvs)-           <- rnLDerivStrategy DerivDeclCtx mds $ \strat_tvs ppr_via_ty ->-              rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "instance" $+           <- rnLDerivStrategy DerivDeclCtx mds $               rnHsSigWcType BindUnlessForall DerivDeclCtx ty        ; warnNoDerivStrat mds' loc-       ; return (DerivDecl noExt ty' mds' overlap, fvs) }+       ; return (DerivDecl noExtField ty' mds' overlap, fvs) }   where     loc = getLoc $ hsib_body $ hswc_body ty-rnSrcDerivDecl (XDerivDecl _) = panic "rnSrcDerivDecl"+rnSrcDerivDecl (XDerivDecl nec) = noExtCon nec  standaloneDerivErr :: SDoc standaloneDerivErr@@ -1005,10 +997,10 @@ rnHsRuleDecls (HsRules { rds_src = src                        , rds_rules = rules })   = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules-       ; return (HsRules { rds_ext = noExt+       ; return (HsRules { rds_ext = noExtField                          , rds_src = src                          , rds_rules = rn_rules }, fvs) }-rnHsRuleDecls (XRuleDecls _) = panic "rnHsRuleDecls"+rnHsRuleDecls (XRuleDecls nec) = noExtCon nec  rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars) rnHsRuleDecl (HsRule { rd_name = rule_name@@ -1037,9 +1029,9 @@   where     get_var (RuleBndrSig _ v _) = v     get_var (RuleBndr _ v)      = v-    get_var (XRuleBndr _)       = panic "rnHsRuleDecl"+    get_var (XRuleBndr nec)     = noExtCon nec     in_rule = text "in the rule" <+> pprFullRuleName rule_name-rnHsRuleDecl (XRuleDecl _) = panic "rnHsRuleDecl"+rnHsRuleDecl (XRuleDecl nec) = noExtCon nec  bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs                -> [LRuleBndr GhcPs] -> [Name]@@ -1051,13 +1043,13 @@   where     go ((dL->L l (RuleBndr _ (dL->L loc _))) : vars) (n : ns) thing_inside       = go vars ns $ \ vars' ->-        thing_inside (cL l (RuleBndr noExt (cL loc n)) : vars')+        thing_inside (cL l (RuleBndr noExtField (cL loc n)) : vars')      go ((dL->L l (RuleBndrSig _ (dL->L loc _) bsig)) : vars)        (n : ns) thing_inside       = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' ->         go vars ns $ \ vars' ->-        thing_inside (cL l (RuleBndrSig noExt (cL loc n) bsig') : vars')+        thing_inside (cL l (RuleBndrSig noExtField (cL loc n) bsig') : vars')      go [] [] thing_inside = thing_inside []     go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)@@ -1187,7 +1179,7 @@   This has a kind error, but the error message is better if you   check T first, (fixing its kind) and *then* S.  If you do kind   inference together, you might get an error reported in S, which-  is jolly confusing.  See Trac #4875+  is jolly confusing.  See #4875   * Increase kind polymorphism.  See TcTyClsDecls@@ -1195,7 +1187,7 @@  Why do the instance declarations participate?  At least two reasons -* Consider (Trac #11348)+* Consider (#11348)       type family F a      type instance F Int = Bool@@ -1208,7 +1200,7 @@   know that unless we've looked at the type instance declaration for F   before kind-checking Foo. -* Another example is this (Trac #3990).+* Another example is this (#3990).       data family Complex a      data instance Complex Double = CD {-# UNPACK #-} !Double@@ -1297,71 +1289,130 @@ -- Rename the declarations and do dependency analysis on them rnTyClDecls tycl_ds   = do { -- Rename the type/class, instance, and role declaraations-         tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl)-                             (tyClGroupTyClDecls tycl_ds)+       ; tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupTyClDecls tycl_ds)        ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs)-+       ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds)        ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)        ; role_annots  <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)         -- Do SCC analysis on the type/class decls        ; rdr_env <- getGlobalRdrEnv-       ; let tycl_sccs = depAnalTyClDecls rdr_env tycls_w_fvs+       ; let tycl_sccs = depAnalTyClDecls rdr_env kisig_fv_env tycls_w_fvs              role_annot_env = mkRoleAnnotEnv role_annots+             (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs               inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs              (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map               first_group                | null init_inst_ds = []-               | otherwise = [TyClGroup { group_ext    = noExt+               | otherwise = [TyClGroup { group_ext    = noExtField                                         , group_tyclds = []+                                        , group_kisigs = []                                         , group_roles  = []                                         , group_instds = init_inst_ds }] -             ((final_inst_ds, orphan_roles), groups)-                = mapAccumL mk_group (rest_inst_ds, role_annot_env) tycl_sccs-+             (final_inst_ds, groups)+                = mapAccumL (mk_group role_annot_env kisig_env) rest_inst_ds tycl_sccs -             all_fvs = plusFV (foldr (plusFV . snd) emptyFVs tycls_w_fvs)-                              (foldr (plusFV . snd) emptyFVs instds_w_fvs)+             all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs  `plusFV`+                       foldr (plusFV . snd) emptyFVs instds_w_fvs `plusFV`+                       foldr (plusFV . snd) emptyFVs kisigs_w_fvs               all_groups = first_group ++ groups -       ; ASSERT2( null final_inst_ds,  ppr instds_w_fvs $$ ppr inst_ds_map+       ; MASSERT2( null final_inst_ds,  ppr instds_w_fvs $$ ppr inst_ds_map                                        $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds  )-         mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles)         ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)        ; return (all_groups, all_fvs) }   where-    mk_group :: (InstDeclFreeVarsMap, RoleAnnotEnv)+    mk_group :: RoleAnnotEnv+             -> KindSigEnv+             -> InstDeclFreeVarsMap              -> SCC (LTyClDecl GhcRn)-             -> ( (InstDeclFreeVarsMap, RoleAnnotEnv)-                , TyClGroup GhcRn )-    mk_group (inst_map, role_env) scc-      = ((inst_map', role_env'), group)+             -> (InstDeclFreeVarsMap, TyClGroup GhcRn)+    mk_group role_env kisig_env inst_map scc+      = (inst_map', group)       where         tycl_ds              = flattenSCC scc         bndrs                = map (tcdName . unLoc) tycl_ds+        roles                = getRoleAnnots bndrs role_env+        kisigs               = getKindSigs   bndrs kisig_env         (inst_ds, inst_map') = getInsts      bndrs inst_map-        (roles,   role_env') = getRoleAnnots bndrs role_env-        group = TyClGroup { group_ext    = noExt+        group = TyClGroup { group_ext    = noExtField                           , group_tyclds = tycl_ds+                          , group_kisigs = kisigs                           , group_roles  = roles                           , group_instds = inst_ds } +-- | Free variables of standalone kind signatures.+newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars) +lookupKindSig_FV_Env :: KindSig_FV_Env -> Name -> FreeVars+lookupKindSig_FV_Env (KindSig_FV_Env e) name+  = fromMaybe emptyFVs (lookupNameEnv e name)++-- | Standalone kind signatures.+type KindSigEnv = NameEnv (LStandaloneKindSig GhcRn)++mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, FreeVars)] -> (KindSigEnv, KindSig_FV_Env)+mkKindSig_fv_env kisigs_w_fvs = (kisig_env, kisig_fv_env)+  where+    kisig_env = mapNameEnv fst compound_env+    kisig_fv_env = KindSig_FV_Env (mapNameEnv snd compound_env)+    compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars)+      = mkNameEnvWith (standaloneKindSigName . unLoc . fst) kisigs_w_fvs++getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn]+getKindSigs bndrs kisig_env = mapMaybe (lookupNameEnv kisig_env) bndrs++rnStandaloneKindSignatures+  :: NameSet  -- names of types and classes in the current TyClGroup+  -> [LStandaloneKindSig GhcPs]+  -> RnM [(LStandaloneKindSig GhcRn, FreeVars)]+rnStandaloneKindSignatures tc_names kisigs+  = do { let (no_dups, dup_kisigs) = removeDups (compare `on` get_name) kisigs+             get_name = standaloneKindSigName . unLoc+       ; mapM_ dupKindSig_Err dup_kisigs+       ; mapM (wrapLocFstM (rnStandaloneKindSignature tc_names)) no_dups+       }++rnStandaloneKindSignature+  :: NameSet  -- names of types and classes in the current TyClGroup+  -> StandaloneKindSig GhcPs+  -> RnM (StandaloneKindSig GhcRn, FreeVars)+rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki)+  = do  { standalone_ki_sig_ok <- xoptM LangExt.StandaloneKindSignatures+        ; unless standalone_ki_sig_ok $ addErr standaloneKiSigErr+        ; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) (text "standalone kind signature") v+        ; let doc = StandaloneKindSigCtx (ppr v)+        ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki+        ; return (StandaloneKindSig noExtField new_v new_ki, fvs)+        }+  where+    standaloneKiSigErr :: SDoc+    standaloneKiSigErr =+      hang (text "Illegal standalone kind signature")+         2 (text "Did you mean to enable StandaloneKindSignatures?")+rnStandaloneKindSignature _ (XStandaloneKindSig nec) = noExtCon nec+ depAnalTyClDecls :: GlobalRdrEnv+                 -> KindSig_FV_Env                  -> [(LTyClDecl GhcRn, FreeVars)]                  -> [SCC (LTyClDecl GhcRn)] -- See Note [Dependency analysis of type, class, and instance decls]-depAnalTyClDecls rdr_env ds_w_fvs+depAnalTyClDecls rdr_env kisig_fv_env ds_w_fvs   = stronglyConnCompFromEdgedVerticesUniq edges   where     edges :: [ Node Name (LTyClDecl GhcRn) ]-    edges = [ DigraphNode d (tcdName (unLoc d)) (map (getParent rdr_env) (nonDetEltsUniqSet fvs))-            | (d, fvs) <- ds_w_fvs ]+    edges = [ DigraphNode d name (map (getParent rdr_env) (nonDetEltsUniqSet deps))+            | (d, fvs) <- ds_w_fvs,+              let { name = tcdName (unLoc d)+                  ; kisig_fvs = lookupKindSig_FV_Env kisig_fv_env name+                  ; deps = fvs `plusFV` kisig_fvs+                  }+            ]             -- It's OK to use nonDetEltsUFM here as             -- stronglyConnCompFromEdgedVertices is still deterministic             -- even if the edges are in nondeterministic order as explained@@ -1401,9 +1452,8 @@ rnRoleAnnots tc_names role_annots   = do {  -- Check for duplicates *before* renaming, to avoid           -- lumping together all the unboundNames-         let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots-             role_annots_cmp (dL->L _ annot1) (dL->L _ annot2)-               = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2+         let (no_dups, dup_annots) = removeDups (compare `on` get_name) role_annots+             get_name = roleAnnotDeclName . unLoc        ; mapM_ dupRoleAnnotErr dup_annots        ; mapM (wrapLocM rn_role_annot1) no_dups }   where@@ -1413,8 +1463,8 @@              tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names)                                           (text "role annotation")                                           tycon-           ; return $ RoleAnnotDecl noExt tycon' roles }-    rn_role_annot1 (XRoleAnnotDecl _) = panic "rnRoleAnnots"+           ; return $ RoleAnnotDecl noExtField tycon' roles }+    rn_role_annot1 (XRoleAnnotDecl nec) = noExtCon nec  dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () dupRoleAnnotErr list@@ -1431,16 +1481,21 @@        cmp_annot (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2 -orphanRoleAnnotErr :: LRoleAnnotDecl GhcRn -> RnM ()-orphanRoleAnnotErr (dL->L loc decl)+dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM ()+dupKindSig_Err list   = addErrAt loc $-    hang (text "Role annotation for a type previously declared:")-       2 (ppr decl) $$-    parens (text "The role annotation must be given where" <+>-            quotes (ppr $ roleAnnotDeclName decl) <+>-            text "is declared.")+    hang (text "Duplicate standalone kind signatures for" <+>+          quotes (ppr $ standaloneKindSigName first_decl) <> colon)+       2 (vcat $ map pp_kisig $ NE.toList sorted_list)+    where+      sorted_list = NE.sortBy cmp_loc list+      ((dL->L loc first_decl) :| _) = sorted_list +      pp_kisig (dL->L loc decl) =+        hang (ppr decl) 4 (text "-- written at" <+> ppr loc) +      cmp_loc (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2+ {- Note [Role annotations in the renamer] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We must ensure that a type's role annotation is put in the same group as the@@ -1455,21 +1510,8 @@ of one another.  The renaming process, as usual, might identify and report errors for unbound-names. We exclude the annotations for unbound names in the annotation-environment to avoid spurious errors for orphaned annotations.--We then (in rnTyClDecls) do a check for orphan role annotations (role-annotations without an accompanying type decl). The check works by folding-over components (of type [[Either (TyClDecl Name) (InstDecl Name)]]), selecting-out the relevant role declarations for each group, as well as diminishing the-annotation environment. After the fold is complete, anything left over in the-name environment must be an orphan, and errors are generated.--An earlier version of this algorithm short-cut the orphan check by renaming-only with names declared in this module. But, this check is insufficient in-the case of staged module compilation (Template Haskell, GHCi).-See #8485. With the new lookup process (which includes types declared in other-modules), we get better error messages, too.+names. This is done by using lookupSigCtxtOccRn in rnRoleAnnots (using+lookupGlobalOccRn led to #8485). -}  @@ -1527,12 +1569,11 @@ rnTyClDecl :: TyClDecl GhcPs            -> RnM (TyClDecl GhcRn, FreeVars) --- All flavours of type family declarations ("type family", "newtype family",--- and "data family"), both top level and (for an associated type)--- in a class decl-rnTyClDecl (FamDecl { tcdFam = decl })-  = do { (decl', fvs) <- rnFamDecl Nothing decl-       ; return (FamDecl noExt decl', fvs) }+-- All flavours of top-level type family declarations ("type family", "newtype+-- family", and "data family")+rnTyClDecl (FamDecl { tcdFam = fam })+  = do { (fam', fvs) <- rnFamDecl Nothing fam+       ; return (FamDecl noExtField fam', fvs) }  rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,                       tcdFixity = fixity, tcdRhs = rhs })@@ -1547,18 +1588,20 @@                          , tcdRhs = rhs', tcdSExt = fvs }, fvs) } }  -- "data", "newtype" declarations--- both top level and (for an associated type) in an instance decl-rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars,-                       tcdFixity = fixity, tcdDataDefn = defn })+rnTyClDecl (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec+rnTyClDecl (DataDecl+    { tcdLName = tycon, tcdTyVars = tyvars,+      tcdFixity = fixity,+      tcdDataDefn = defn@HsDataDefn{ dd_ND = new_or_data+                                   , dd_kindSig = kind_sig} })   = do { tycon' <- lookupLocatedTopBndrRn tycon        ; let kvs = extractDataDefnKindVars defn              doc = TyDataCtx tycon        ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)        ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->     do { (defn', fvs) <- rnDataDefn doc defn-          -- See Note [Complete user-supplied kind signatures] in HsDecls-       ; let cusk = hsTvbAllKinded tyvars' && no_rhs_kvs-             rn_info = DataDeclRn { tcdDataCusk = cusk+       ; cusk <- data_decl_has_cusk tyvars' new_or_data no_rhs_kvs kind_sig+       ; let rn_info = DataDeclRn { tcdDataCusk = cusk                                   , tcdFVs      = fvs }        ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs)        ; return (DataDecl { tcdLName    = tycon'@@ -1589,7 +1632,7 @@                          fv_ats              ; return ((tyvars', context', fds', ats'), fvs) } -        ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs+        ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltDecl cls') at_defs          -- No need to check for duplicate associated type decls         -- since that is done by RnNames.extendGlobalRdrEnvRn@@ -1632,8 +1675,42 @@   where     cls_doc  = ClassDeclCtx lcls -rnTyClDecl (XTyClDecl _) = panic "rnTyClDecl"+rnTyClDecl (XTyClDecl nec) = noExtCon nec +-- Does the data type declaration include a CUSK?+data_decl_has_cusk :: LHsQTyVars pass -> NewOrData -> Bool -> Maybe (LHsKind pass') -> RnM Bool+data_decl_has_cusk tyvars new_or_data no_rhs_kvs kind_sig = do+  { -- See Note [Unlifted Newtypes and CUSKs], and for a broader+    -- picture, see Note [Implementation of UnliftedNewtypes].+  ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes+  ; let non_cusk_newtype+          | NewType <- new_or_data =+              unlifted_newtypes && isNothing kind_sig+          | otherwise = False+    -- See Note [CUSKs: complete user-supplied kind signatures] in GHC.Hs.Decls+  ; return $ hsTvbAllKinded tyvars && no_rhs_kvs && not non_cusk_newtype+  }++{- Note [Unlifted Newtypes and CUSKs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When unlifted newtypes are enabled, a newtype must have a kind signature+in order to be considered have a CUSK. This is because the flow of+kind inference works differently. Consider:++  newtype Foo = FooC Int++When UnliftedNewtypes is disabled, we decide that Foo has kind+`TYPE 'LiftedRep` without looking inside the data constructor. So, we+can say that Foo has a CUSK. However, when UnliftedNewtypes is enabled,+we fill in the kind of Foo as a metavar that gets solved by unification+with the kind of the field inside FooC (that is, Int, whose kind is+`TYPE 'LiftedRep`). But since we have to look inside the data constructors+to figure out the kind signature of Foo, it does not have a CUSK.++See Note [Implementation of UnliftedNewtypes] for where this fits in to+the broader picture of UnliftedNewtypes.+-}+ -- "type" and "type instance" declarations rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) rnTySyn doc rhs = rnLHsType doc rhs@@ -1664,7 +1741,7 @@          ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`                         con_fvs `plusFV` sig_fvs-        ; return ( HsDataDefn { dd_ext = noExt+        ; return ( HsDataDefn { dd_ext = noExtField                               , dd_ND = new_or_data, dd_cType = cType                               , dd_ctxt = context', dd_kindSig = m_sig'                               , dd_cons = condecls'@@ -1682,7 +1759,7 @@                multipleDerivClausesErr            ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds            ; return (cL loc ds', fvs) }-rnDataDefn _ (XHsDataDefn _) = panic "rnDataDefn"+rnDataDefn _ (XHsDataDefn nec) = noExtCon nec  warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn)                  -> SrcSpan@@ -1711,46 +1788,37 @@                     -> RnM (LHsDerivingClause GhcRn, FreeVars) rnLHsDerivingClause doc                 (dL->L loc (HsDerivingClause-                              { deriv_clause_ext = noExt+                              { deriv_clause_ext = noExtField                               , deriv_clause_strategy = dcs                               , deriv_clause_tys = (dL->L loc' dct) }))   = do { (dcs', dct', fvs)-           <- rnLDerivStrategy doc dcs $ \strat_tvs ppr_via_ty ->-              mapFvRn (rn_deriv_ty strat_tvs ppr_via_ty) dct+           <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc TypeLevel) dct        ; warnNoDerivStrat dcs' loc-       ; pure ( cL loc (HsDerivingClause { deriv_clause_ext = noExt+       ; pure ( cL loc (HsDerivingClause { deriv_clause_ext = noExtField                                          , deriv_clause_strategy = dcs'                                          , deriv_clause_tys = cL loc' dct' })               , fvs ) }-  where-    rn_deriv_ty :: [Name] -> SDoc -> LHsSigType GhcPs-                -> RnM (LHsSigType GhcRn, FreeVars)-    rn_deriv_ty strat_tvs ppr_via_ty deriv_ty@(HsIB {hsib_body = dL->L loc _}) =-      rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "class" $-      rnHsSigType doc deriv_ty-    rn_deriv_ty _ _ (XHsImplicitBndrs _) = panic "rn_deriv_ty"-rnLHsDerivingClause _ (dL->L _ (XHsDerivingClause _))-  = panic "rnLHsDerivingClause"+rnLHsDerivingClause _ (dL->L _ (XHsDerivingClause nec))+  = noExtCon nec rnLHsDerivingClause _ _ = panic "rnLHsDerivingClause: Impossible Match"                                 -- due to #15884  rnLDerivStrategy :: forall a.                     HsDocContext                  -> Maybe (LDerivStrategy GhcPs)-                 -> ([Name]   -- The tyvars bound by the via type-                      -> SDoc -- The pretty-printed via type (used for-                              -- error message reporting)-                      -> RnM (a, FreeVars))+                 -> RnM (a, FreeVars)                  -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars) rnLDerivStrategy doc mds thing_inside   = case mds of       Nothing -> boring_case Nothing-      Just ds -> do (ds', thing, fvs) <- rn_deriv_strat ds-                    pure (Just ds', thing, fvs)+      Just (dL->L loc ds) ->+        setSrcSpan loc $ do+          (ds', thing, fvs) <- rn_deriv_strat ds+          pure (Just (cL loc ds'), thing, fvs)   where-    rn_deriv_strat :: LDerivStrategy GhcPs-                   -> RnM (LDerivStrategy GhcRn, a, FreeVars)-    rn_deriv_strat (dL->L loc ds) = do+    rn_deriv_strat :: DerivStrategy GhcPs+                   -> RnM (DerivStrategy GhcRn, a, FreeVars)+    rn_deriv_strat ds = do       let extNeeded :: LangExt.Extension           extNeeded             | ViaStrategy{} <- ds@@ -1762,75 +1830,23 @@         failWith $ illegalDerivStrategyErr ds        case ds of-        StockStrategy    -> boring_case (cL loc StockStrategy)-        AnyclassStrategy -> boring_case (cL loc AnyclassStrategy)-        NewtypeStrategy  -> boring_case (cL loc NewtypeStrategy)+        StockStrategy    -> boring_case StockStrategy+        AnyclassStrategy -> boring_case AnyclassStrategy+        NewtypeStrategy  -> boring_case NewtypeStrategy         ViaStrategy via_ty ->-          do (via_ty', fvs1) <- rnHsSigType doc via_ty+          do (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty              let HsIB { hsib_ext  = via_imp_tvs                       , hsib_body = via_body } = via_ty'-                 (via_exp_tv_bndrs, _, _) = splitLHsSigmaTy via_body-                 via_exp_tvs = map hsLTyVarName via_exp_tv_bndrs+                 (via_exp_tv_bndrs, _, _) = splitLHsSigmaTyInvis via_body+                 via_exp_tvs = hsLTyVarNames via_exp_tv_bndrs                  via_tvs = via_imp_tvs ++ via_exp_tvs-             (thing, fvs2) <- extendTyVarEnvFVRn via_tvs $-                              thing_inside via_tvs (ppr via_ty')-             pure (cL loc (ViaStrategy via_ty'), thing, fvs1 `plusFV` fvs2)--    boring_case :: mds-                -> RnM (mds, a, FreeVars)-    boring_case mds = do-      (thing, fvs) <- thing_inside [] empty-      pure (mds, thing, fvs)---- | Errors if a @via@ type binds any floating type variables.--- See @Note [Floating `via` type variables]@-rnAndReportFloatingViaTvs-  :: forall a. Outputable a-  => [Name]  -- ^ The bound type variables from a @via@ type.-  -> SrcSpan -- ^ The source span (for error reporting only).-  -> SDoc    -- ^ The pretty-printed @via@ type (for error reporting only).-  -> String  -- ^ A description of what the @via@ type scopes over-             --   (for error reporting only).-  -> RnM (a, FreeVars) -- ^ The thing the @via@ type scopes over.-  -> RnM (a, FreeVars)-rnAndReportFloatingViaTvs tv_names loc ppr_via_ty via_scope_desc thing_inside-  = do (thing, thing_fvs) <- thing_inside-       setSrcSpan loc $ mapM_ (report_floating_via_tv thing thing_fvs) tv_names-       pure (thing, thing_fvs)-  where-    report_floating_via_tv :: a -> FreeVars -> Name -> RnM ()-    report_floating_via_tv thing used_names tv_name-      = unless (tv_name `elemNameSet` used_names) $ addErr $ vcat-          [ text "Type variable" <+> quotes (ppr tv_name) <+>-            text "is bound in the" <+> quotes (text "via") <+>-            text "type" <+> quotes ppr_via_ty-          , text "but is not mentioned in the derived" <+>-            text via_scope_desc <+> quotes (ppr thing) <>-            text ", which is illegal" ]--{--Note [Floating `via` type variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Imagine the following `deriving via` clause:--    data Quux-      deriving Eq via (Const a Quux)--This should be rejected. Why? Because it would generate the following instance:--    instance Eq Quux where-      (==) = coerce @(Quux         -> Quux         -> Bool)-                    @(Const a Quux -> Const a Quux -> Bool)-                    (==) :: Const a Quux -> Const a Quux -> Bool--This instance is ill-formed, as the `a` in `Const a Quux` is unbound. The-problem is that `a` is never used anywhere in the derived class `Eq`. Since-`a` is bound but has no use sites, we refer to it as "floating".+             (thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside+             pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2) -We use the rnAndReportFloatingViaTvs function to check that any type renamed-within the context of the `via` deriving strategy actually uses all bound-`via` type variables, and if it doesn't, it throws an error.--}+    boring_case :: ds -> RnM (ds, a, FreeVars)+    boring_case ds = do+      (thing, fvs) <- thing_inside+      pure (ds, thing, fvs)  badGadtStupidTheta :: HsDocContext -> SDoc badGadtStupidTheta _@@ -1873,7 +1889,7 @@                                           injectivity                ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }        ; (info', fv2) <- rn_info tycon' info-       ; return (FamilyDecl { fdExt = noExt+       ; return (FamilyDecl { fdExt = noExtField                             , fdLName = tycon', fdTyVars = tyvars'                             , fdFixity = fixity                             , fdInfo = info', fdResultSig = res_sig'@@ -1888,7 +1904,7 @@              -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)      rn_info (dL->L _ fam_name) (ClosedTypeFamily (Just eqns))        = do { (eqns', fvs)-                <- rnList (rnTyFamInstEqn Nothing (ClosedTyFam tycon fam_name))+                <- rnList (rnTyFamInstEqn NonAssocTyFamEqn (ClosedTyFam tycon fam_name))                                           -- no class context                           eqns             ; return (ClosedTypeFamily (Just eqns'), fvs) }@@ -1896,16 +1912,16 @@        = return (ClosedTypeFamily Nothing, emptyFVs)      rn_info _ OpenTypeFamily = return (OpenTypeFamily, emptyFVs)      rn_info _ DataFamily     = return (DataFamily, emptyFVs)-rnFamDecl _ (XFamilyDecl _) = panic "rnFamDecl"+rnFamDecl _ (XFamilyDecl nec) = noExtCon nec  rnFamResultSig :: HsDocContext                -> FamilyResultSig GhcPs                -> RnM (FamilyResultSig GhcRn, FreeVars) rnFamResultSig _ (NoSig _)-   = return (NoSig noExt, emptyFVs)+   = return (NoSig noExtField, emptyFVs) rnFamResultSig doc (KindSig _ kind)    = do { (rndKind, ftvs) <- rnLHsKind doc kind-        ;  return (KindSig noExt rndKind, ftvs) }+        ;  return (KindSig noExtField rndKind, ftvs) } rnFamResultSig doc (TyVarSig _ tvbndr)    = do { -- `TyVarSig` tells us that user named the result of a type family by           -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to@@ -1927,8 +1943,8 @@        ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for                                       -- scoping checks that are irrelevant here                           tvbndr $ \ tvbndr' ->-         return (TyVarSig noExt tvbndr', unitFV (hsLTyVarName tvbndr')) }-rnFamResultSig _ (XFamilyResultSig _) = panic "rnFamResultSig"+         return (TyVarSig noExtField tvbndr', unitFV (hsLTyVarName tvbndr')) }+rnFamResultSig _ (XFamilyResultSig nec) = noExtCon nec  -- Note [Renaming injectivity annotation] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2026,7 +2042,7 @@ {- Note [Stupid theta] ~~~~~~~~~~~~~~~~~~~-Trac #3850 complains about a regression wrt 6.10 for+#3850 complains about a regression wrt 6.10 for      data Show a => T a There is no reason not to allow the stupid theta if there are no data constructors.  It's still stupid, but does no harm, and I don't want@@ -2079,7 +2095,7 @@              [ text "ex_tvs:" <+> ppr ex_tvs              , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) -        ; return (decl { con_ext = noExt+        ; return (decl { con_ext = noExtField                        , con_name = new_name, con_ex_tvs = new_ex_tvs                        , con_mb_cxt = new_context, con_args = new_args                        , con_doc = mb_doc' },@@ -2104,7 +2120,7 @@           -- order of their appearance in the constructor type.           -- That order governs the order the implicitly-quantified type           -- variable, and hence the order needed for visible type application-          -- See Trac #14808.+          -- See #14808.               free_tkvs = extractHsTvBndrs explicit_tkvs $                           extractHsTysRdrTyVarsDups (theta ++ arg_tys ++ [res_ty]) @@ -2125,22 +2141,20 @@                       RecCon {}    -> (new_args, new_res_ty)                       PrefixCon as | (arg_tys, final_res_ty) <- splitHsFunType new_res_ty                                    -> ASSERT( null as )-                                      -- See Note [GADT abstract syntax] in HsDecls+                                      -- See Note [GADT abstract syntax] in GHC.Hs.Decls                                       (PrefixCon arg_tys, final_res_ty) -              new_qtvs =  HsQTvs { hsq_ext = HsQTvsRn-                                     { hsq_implicit  = implicit_tkvs-                                     , hsq_dependent = emptyNameSet }+              new_qtvs =  HsQTvs { hsq_ext = implicit_tkvs                                  , hsq_explicit  = explicit_tkvs }          ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs)-        ; return (decl { con_g_ext = noExt, con_names = new_names+        ; return (decl { con_g_ext = noExtField, con_names = new_names                        , con_qvars = new_qtvs, con_mb_cxt = new_cxt                        , con_args = args', con_res_ty = res_ty'                        , con_doc = mb_doc' },                   all_fvs) } } -rnConDecl (XConDecl _) = panic "rnConDecl"+rnConDecl (XConDecl nec) = noExtCon nec   rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)@@ -2189,7 +2203,7 @@    ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }   where     new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]-    new_ps (ValBinds _ binds _) = foldrBagM new_ps' [] binds+    new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds     new_ps _ = panic "new_ps"      new_ps' :: LHsBindLR GhcPs GhcPs@@ -2202,7 +2216,7 @@           bnd_name <- newTopSrcBinder (cL bind_loc n)           let rnames = map recordPatSynSelectorId as               mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs-              mkFieldOcc (dL->L l name) = cL l (FieldOcc noExt (cL l name))+              mkFieldOcc (dL->L l name) = cL l (FieldOcc noExtField (cL l name))               field_occs =  map mkFieldOcc rnames           flds     <- mapM (newRecordSelector False [bnd_name]) field_occs           return ((bnd_name, flds): names)@@ -2289,7 +2303,7 @@                      -- The compiler should suggest the above, and not using                      -- TemplateHaskell since the former suggestion is more                      -- relevant to the larger base of users.-                     -- See Trac #12146 for discussion.+                     -- See #12146 for discussion.  -- Class declarations: pull out the fixity signatures to the top add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD _ d) ds@@ -2303,6 +2317,11 @@ -- Signatures: fixity sigs go a different place than all others add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds   = addl (gp {hs_fixds = cL l f : ts}) ds++-- Standalone kind signatures: added to the TyClGroup+add gp@(HsGroup {hs_tyclds = ts}) l (KindSigD _ s) ds+  = addl (gp {hs_tyclds = add_kisig (cL l s) ts}) ds+ add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds   = addl (gp {hs_valds = add_sig (cL l d) ts}) ds @@ -2335,45 +2354,61 @@   = addl (gp { hs_ruleds = cL l d : ts }) ds add gp l (DocD _ d) ds   = addl (gp { hs_docs = (cL l d) : (hs_docs gp) })  ds-add (HsGroup {}) _ (SpliceD _ (XSpliceDecl _)) _ = panic "RnSource.add"-add (HsGroup {}) _ (XHsDecl _)                 _ = panic "RnSource.add"-add (XHsGroup _) _ _                           _ = panic "RnSource.add"+add (HsGroup {}) _ (SpliceD _ (XSpliceDecl nec)) _ = noExtCon nec+add (HsGroup {}) _ (XHsDecl nec)                 _ = noExtCon nec+add (XHsGroup nec) _ _                           _ = noExtCon nec  add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)]           -> [TyClGroup (GhcPass p)]-add_tycld d []       = [TyClGroup { group_ext    = noExt+add_tycld d []       = [TyClGroup { group_ext    = noExtField                                   , group_tyclds = [d]+                                  , group_kisigs = []                                   , group_roles  = []                                   , group_instds = []                                   }                        ] add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)   = ds { group_tyclds = d : tyclds } : dss-add_tycld _ (XTyClGroup _: _) = panic "add_tycld"+add_tycld _ (XTyClGroup nec: _) = noExtCon nec  add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)]           -> [TyClGroup (GhcPass p)]-add_instd d []       = [TyClGroup { group_ext    = noExt+add_instd d []       = [TyClGroup { group_ext    = noExtField                                   , group_tyclds = []+                                  , group_kisigs = []                                   , group_roles  = []                                   , group_instds = [d]                                   }                        ] add_instd d (ds@(TyClGroup { group_instds = instds }):dss)   = ds { group_instds = d : instds } : dss-add_instd _ (XTyClGroup _: _) = panic "add_instd"+add_instd _ (XTyClGroup nec: _) = noExtCon nec  add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)]                -> [TyClGroup (GhcPass p)]-add_role_annot d [] = [TyClGroup { group_ext    = noExt+add_role_annot d [] = [TyClGroup { group_ext    = noExtField                                  , group_tyclds = []+                                 , group_kisigs = []                                  , group_roles  = [d]                                  , group_instds = []                                  }                       ] add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)   = tycls { group_roles = d : roles } : rest-add_role_annot _ (XTyClGroup _: _) = panic "add_role_annot"+add_role_annot _ (XTyClGroup nec: _) = noExtCon nec++add_kisig :: LStandaloneKindSig (GhcPass p)+         -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]+add_kisig d [] = [TyClGroup { group_ext    = noExtField+                            , group_tyclds = []+                            , group_kisigs = [d]+                            , group_roles  = []+                            , group_instds = []+                            }+                 ]+add_kisig d (tycls@(TyClGroup { group_kisigs = kisigs }) : rest)+  = tycls { group_kisigs = d : kisigs } : rest+add_kisig _ (XTyClGroup nec : _) = noExtCon nec  add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs
compiler/rename/RnSplice.hs view
@@ -10,13 +10,13 @@         , traceSplice, SpliceInfo(..)   ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import Name import NameSet-import HsSyn+import GHC.Hs import RdrName import TcRnMonad @@ -104,7 +104,7 @@                         ; (body', fvs_e) <-                           setStage (Brack cur_stage RnPendingTyped) $                                    rn_bracket cur_stage br_body-                        ; return (HsBracket noExt body', fvs_e) }+                        ; return (HsBracket noExtField body', fvs_e) }              False -> do { traceRn "Renaming untyped TH bracket" empty                         ; ps_var <- newMutVar []@@ -112,7 +112,7 @@                           setStage (Brack cur_stage (RnPendingUntyped ps_var)) $                                    rn_bracket cur_stage br_body                         ; pendings <- readMutVar ps_var-                        ; return (HsRnBracketOut noExt body' pendings, fvs_e) }+                        ; return (HsRnBracketOut noExtField body' pendings, fvs_e) }        }  rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars)@@ -180,7 +180,7 @@ rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e                                ; return (TExpBr x e', fvs) } -rn_bracket _ (XBracket {}) = panic "rn_bracket: unexpected XBracket"+rn_bracket _ (XBracket nec) = noExtCon nec  quotationCtxtDoc :: HsBracket GhcPs -> SDoc quotationCtxtDoc br_body@@ -303,7 +303,7 @@                 HsTypedSplice {}          -> pprPanic "runRnSplice" (ppr splice)                 HsSpliced {}              -> pprPanic "runRnSplice" (ppr splice)                 HsSplicedT {}             -> pprPanic "runRnSplice" (ppr splice)-                XSplice {}                -> pprPanic "runRnSplice" (ppr splice)+                XSplice nec               -> noExtCon nec               -- Typecheck the expression        ; meta_exp_ty   <- tcMetaTy meta_ty_name@@ -352,8 +352,8 @@   = pprPanic "makePending" (ppr splice) makePending _ splice@(HsSplicedT {})   = pprPanic "makePending" (ppr splice)-makePending _ splice@(XSplice {})-  = pprPanic "makePending" (ppr splice)+makePending _ (XSplice nec)+  = noExtCon nec  ------------------ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString@@ -361,13 +361,13 @@ -- Return the expression (quoter "...quote...") -- which is what we must run in a quasi-quote mkQuasiQuoteExpr flavour quoter q_span quote-  = cL q_span $ HsApp noExt (cL q_span-              $ HsApp noExt (cL q_span (HsVar noExt (cL q_span quote_selector)))-                            quoterExpr)+  = cL q_span $ HsApp noExtField (cL q_span+              $ HsApp noExtField (cL q_span (HsVar noExtField (cL q_span quote_selector)))+                                 quoterExpr)                      quoteExpr   where-    quoterExpr = cL q_span $! HsVar noExt $! (cL q_span quoter)-    quoteExpr  = cL q_span $! HsLit noExt $! HsString NoSourceText quote+    quoterExpr = cL q_span $! HsVar noExtField $! (cL q_span quoter)+    quoteExpr  = cL q_span $! HsLit noExtField $! HsString NoSourceText quote     quote_selector = case flavour of                        UntypedExpSplice  -> quoteExpName                        UntypedPatSplice  -> quotePatName@@ -378,22 +378,19 @@ rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars) -- Not exported...used for all rnSplice (HsTypedSplice x hasParen splice_name expr)-  = do  { checkTH expr "Template Haskell typed splice"-        ; loc  <- getSrcSpanM+  = do  { loc  <- getSrcSpanM         ; n' <- newLocalBndrRn (cL loc splice_name)         ; (expr', fvs) <- rnLExpr expr         ; return (HsTypedSplice x hasParen n' expr', fvs) }  rnSplice (HsUntypedSplice x hasParen splice_name expr)-  = do  { checkTH expr "Template Haskell untyped splice"-        ; loc  <- getSrcSpanM+  = do  { loc  <- getSrcSpanM         ; n' <- newLocalBndrRn (cL loc splice_name)         ; (expr', fvs) <- rnLExpr expr         ; return (HsUntypedSplice x hasParen n' expr', fvs) }  rnSplice (HsQuasiQuote x splice_name quoter q_loc quote)-  = do  { checkTH quoter "Template Haskell quasi-quote"-        ; loc  <- getSrcSpanM+  = do  { loc  <- getSrcSpanM         ; splice_name' <- newLocalBndrRn (cL loc splice_name)            -- Rename the quoter; akin to the HsVar case of rnExpr@@ -407,7 +404,7 @@  rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice) rnSplice splice@(HsSplicedT {}) = pprPanic "rnSplice" (ppr splice)-rnSplice splice@(XSplice {})   = pprPanic "rnSplice" (ppr splice)+rnSplice        (XSplice nec)   = noExtCon nec  --------------------- rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars)@@ -416,7 +413,7 @@   where     pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn)     pend_expr_splice rn_splice-        = (makePending UntypedExpSplice rn_splice, HsSpliceE noExt rn_splice)+        = (makePending UntypedExpSplice rn_splice, HsSpliceE noExtField rn_splice)      run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars)     run_expr_splice rn_splice@@ -429,7 +426,7 @@                                                      , isLocalGRE gre]                  lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) -           ; return (HsSpliceE noExt rn_splice, lcl_names `plusFV` gbl_names) }+           ; return (HsSpliceE noExtField rn_splice, lcl_names `plusFV` gbl_names) }        | otherwise  -- Run it here, see Note [Running splices in the Renamer]       = do { traceRn "rnSpliceExpr: untyped expression splice" empty@@ -437,8 +434,8 @@                 runRnSplice UntypedExpSplice runMetaE ppr rn_splice            ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)              -- See Note [Delaying modFinalizers in untyped splices].-           ; return ( HsPar noExt $ HsSpliceE noExt-                            . HsSpliced noExt (ThModFinalizers mod_finalizers)+           ; return ( HsPar noExtField $ HsSpliceE noExtField+                            . HsSpliced noExtField (ThModFinalizers mod_finalizers)                             . HsSplicedExpr <$>                             lexpr3                     , fvs)@@ -447,16 +444,16 @@ {- Note [Running splices in the Renamer] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Splices used to be run in the typechecker, which led to (Trac #4364). Since the+Splices used to be run in the typechecker, which led to (#4364). Since the renamer must decide which expressions depend on which others, and it cannot reliably do this for arbitrary splices, we used to conservatively say that splices depend on all other expressions in scope. Unfortunately, this led to-the problem of cyclic type declarations seen in (Trac #4364). Instead, by+the problem of cyclic type declarations seen in (#4364). Instead, by running splices in the renamer, we side-step the problem of determining dependencies: by the time the dependency analysis happens, any splices have already been run, and expression dependencies can be determined as usual. -However, see (Trac #9813), for an example where we would like to run splices+However, see (#9813), for an example where we would like to run splices *after* performing dependency analysis (that is, after renaming). It would be desirable to typecheck "non-splicy" expressions (those expressions that do not contain splices directly or via dependence on an expression that does) before@@ -477,7 +474,7 @@ making them available to reify, but cannot accurately determine dependencies without running splices in the renamer! -Indeed, the conclusion of (Trac #9813) was that it is not worth the complexity+Indeed, the conclusion of (#9813) was that it is not worth the complexity to try and  a) implement and maintain the code for renaming/typechecking non-splicy     expressions before splicy expressions,@@ -490,7 +487,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  When splices run in the renamer, 'reify' does not have access to the local-type environment (Trac #11832, [1]).+type environment (#11832, [1]).  For instance, in @@ -525,7 +522,7 @@  References: -[1] https://ghc.haskell.org/trac/ghc/wiki/TemplateHaskell/Reify+[1] https://gitlab.haskell.org/ghc/ghc/wikis/template-haskell/reify [2] 'rnSpliceExpr' [3] 'TcSplice.qAddModFinalizer' [4] 'TcExpr.tcExpr' ('HsSpliceE' ('HsSpliced' ...))@@ -541,7 +538,7 @@   where     pend_type_splice rn_splice        = ( makePending UntypedTypeSplice rn_splice-         , HsSpliceTy noExt rn_splice)+         , HsSpliceTy noExtField rn_splice)      run_type_splice rn_splice       = do { traceRn "rnSpliceType: untyped type splice" empty@@ -551,8 +548,9 @@                                  ; checkNoErrs $ rnLHsType doc hs_ty2 }                                     -- checkNoErrs: see Note [Renamer errors]              -- See Note [Delaying modFinalizers in untyped splices].-           ; return ( HsParTy noExt $ HsSpliceTy noExt-                              . HsSpliced noExt (ThModFinalizers mod_finalizers)+           ; return ( HsParTy noExtField+                              $ HsSpliceTy noExtField+                              . HsSpliced noExtField (ThModFinalizers mod_finalizers)                               . HsSplicedTy <$>                               hs_ty3                     , fvs@@ -611,7 +609,7 @@                        (PendingRnSplice, Either b (Pat GhcRn))     pend_pat_splice rn_splice       = (makePending UntypedPatSplice rn_splice-        , Right (SplicePat noExt rn_splice))+        , Right (SplicePat noExtField rn_splice))      run_pat_splice :: HsSplice GhcRn ->                       RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars)@@ -620,8 +618,8 @@            ; (pat, mod_finalizers) <-                 runRnSplice UntypedPatSplice runMetaP ppr rn_splice              -- See Note [Delaying modFinalizers in untyped splices].-           ; return ( Left $ ParPat noExt $ ((SplicePat noExt)-                              . HsSpliced noExt (ThModFinalizers mod_finalizers)+           ; return ( Left $ ParPat noExtField $ ((SplicePat noExtField)+                              . HsSpliced noExtField (ThModFinalizers mod_finalizers)                               . HsSplicedPat)  `onHasSrcSpan`                               pat                     , emptyFVs@@ -636,10 +634,10 @@   where     pend_decl_splice rn_splice        = ( makePending UntypedDeclSplice rn_splice-         , SpliceDecl noExt (cL loc rn_splice) flg)+         , SpliceDecl noExtField (cL loc rn_splice) flg) -    run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice)-rnSpliceDecl (XSpliceDecl _) = panic "rnSpliceDecl"+    run_decl_splice rn_splice  = pprPanic "rnSpliceDecl" (ppr rn_splice)+rnSpliceDecl (XSpliceDecl nec) = noExtCon nec  rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) -- Declaration splice at the very top level of the module@@ -856,7 +854,7 @@  This must be done by the renamer, not the type checker (as of old), because the type checker doesn't typecheck the body of untyped-brackets (Trac #8540).+brackets (#8540).  A thing can have a bind_lvl of outerLevel, but have an internal name:    foo = [d| op = 3
compiler/rename/RnSplice.hs-boot view
@@ -1,7 +1,7 @@ module RnSplice where  import GhcPrelude-import HsSyn+import GHC.Hs import TcRnMonad import NameSet
compiler/rename/RnTypes.hs view
@@ -26,14 +26,11 @@         -- Binding related stuff         bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs,         bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,-        extractFilteredRdrTyVars, extractFilteredRdrTyVarsDups,         extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,-        extractHsTyRdrTyVarsDups, extractHsTysRdrTyVars,-        extractHsTysRdrTyVarsDups, rmDupsInRdrTyVars,+        extractHsTysRdrTyVarsDups,         extractRdrKindSigVars, extractDataDefnKindVars,         extractHsTvBndrs, extractHsTyArgRdrKiTyVarsDup,-        freeKiTyVarsAllVars, freeKiTyVarsKindVars, freeKiTyVarsTypeVars,-        elemRdr+        nubL, elemRdr   ) where  import GhcPrelude@@ -41,7 +38,7 @@ import {-# SOURCE #-} RnSplice( rnSpliceType )  import DynFlags-import HsSyn+import GHC.Hs import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc ) import RnEnv import RnUtils          ( HsDocContext(..), withHsDocContext, mapFvRn@@ -60,8 +57,9 @@  import Util import ListSetOps       ( deleteBys )-import BasicTypes       ( compareFixity, funTyFixity, negateFixity,-                          Fixity(..), FixityDirection(..), LexicalFixity(..) )+import BasicTypes       ( compareFixity, funTyFixity, negateFixity+                        , Fixity(..), FixityDirection(..), LexicalFixity(..)+                        , TypeOrKind(..) ) import Outputable import FastString import Maybes@@ -70,7 +68,7 @@ import Data.List          ( nubBy, partition, (\\) ) import Control.Monad      ( unless, when ) -#include "GhclibHsVersions.h"+#include "HsVersions.h"  {- These type renamers are in a separate module, rather than in (say) RnSource,@@ -127,7 +125,7 @@                   (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})                   thing_inside   = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty-       ; (tv_rdrs, nwc_rdrs') <- partition_nwcs free_vars+       ; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars        ; let nwc_rdrs = nubL nwc_rdrs'              bind_free_tvs = case scoping of                                AlwaysBind       -> True@@ -140,19 +138,19 @@                             , hsib_body = hs_ty' }        ; (res, fvs2) <- thing_inside sig_ty'        ; return (res, fvs1 `plusFV` fvs2) } }-rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs _)) _-  = panic "rn_hs_sig_wc_type"-rn_hs_sig_wc_type _ _ (XHsWildCardBndrs _) _-  = panic "rn_hs_sig_wc_type"+rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs nec)) _+  = noExtCon nec+rn_hs_sig_wc_type _ _ (XHsWildCardBndrs nec) _+  = noExtCon nec  rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars) rnHsWcType ctxt (HsWC { hswc_body = hs_ty })   = do { free_vars <- extractFilteredRdrTyVars hs_ty-       ; (_, nwc_rdrs) <- partition_nwcs free_vars+       ; (nwc_rdrs, _) <- partition_nwcs free_vars        ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty        ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' }        ; return (sig_ty', fvs) }-rnHsWcType _ (XHsWildCardBndrs _) = panic "rnHsWcType"+rnHsWcType _ (XHsWildCardBndrs nec) = noExtCon nec  rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs          -> RnM ([Name], LHsType GhcRn, FreeVars)@@ -173,11 +171,13 @@      rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)     -- A lot of faff just to allow the extra-constraints wildcard to appear-    rn_ty env hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_body })+    rn_ty env hs_ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs+                                , hst_body = hs_body })       = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) Nothing tvs $ \ tvs' ->         do { (hs_body', fvs) <- rn_lty env hs_body-           ; return (HsForAllTy { hst_xforall = noExt, hst_bndrs = tvs'-                                , hst_body = hs_body' }, fvs) }+           ; return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField+                                , hst_bndrs = tvs', hst_body = hs_body' }+                    , fvs) }      rn_ty env (HsQualTy { hst_ctxt = dL->L cx hs_ctxt                         , hst_body = hs_ty })@@ -185,16 +185,16 @@       , (dL->L lx (HsWildCardTy _))  <- ignoreParens hs_ctxt_last       = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1            ; setSrcSpan lx $ checkExtraConstraintWildCard env hs_ctxt1-           ; let hs_ctxt' = hs_ctxt1' ++ [cL lx (HsWildCardTy noExt)]+           ; let hs_ctxt' = hs_ctxt1' ++ [cL lx (HsWildCardTy noExtField)]            ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty-           ; return (HsQualTy { hst_xqual = noExt+           ; return (HsQualTy { hst_xqual = noExtField                               , hst_ctxt = cL cx hs_ctxt', hst_body = hs_ty' }                     , fvs1 `plusFV` fvs2) }        | otherwise       = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt            ; (hs_ty', fvs2)   <- rnLHsTyKi env hs_ty-           ; return (HsQualTy { hst_xqual = noExt+           ; return (HsQualTy { hst_xqual = noExtField                               , hst_ctxt = cL cx hs_ctxt'                               , hst_body = hs_ty' }                     , fvs1 `plusFV` fvs2) }@@ -243,6 +243,7 @@       TypeSigCtx {}       -> True       ExprWithTySigCtx {} -> True       DerivDeclCtx {}     -> True+      StandaloneKindSigCtx {} -> False  -- See Note [Wildcards in standalone kind signatures] in GHC/Hs/Decls       _                   -> False  -- | Finds free type and kind variables in a type,@@ -251,9 +252,7 @@ --   NB: this includes named wildcards, which look like perfectly --       ordinary type variables at this point extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsNoDups-extractFilteredRdrTyVars hs_ty-  = do { rdr_env <- getLocalRdrEnv-       ; return (filterInScope rdr_env (extractHsTyRdrTyVars hs_ty)) }+extractFilteredRdrTyVars hs_ty = filterInScopeM (extractHsTyRdrTyVars hs_ty)  -- | Finds free type and kind variables in a type, --     with duplicates, but@@ -261,22 +260,20 @@ --   NB: this includes named wildcards, which look like perfectly --       ordinary type variables at this point extractFilteredRdrTyVarsDups :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups-extractFilteredRdrTyVarsDups hs_ty-  = do { rdr_env <- getLocalRdrEnv-       ; return (filterInScope rdr_env (extractHsTyRdrTyVarsDups hs_ty)) }+extractFilteredRdrTyVarsDups hs_ty = filterInScopeM (extractHsTyRdrTyVarsDups hs_ty)  -- | When the NamedWildCards extension is enabled, partition_nwcs -- removes type variables that start with an underscore from the -- FreeKiTyVars in the argument and returns them in a separate list. -- When the extension is disabled, the function returns the argument -- and empty list.  See Note [Renaming named wild cards]-partition_nwcs :: FreeKiTyVars -> RnM (FreeKiTyVars, [Located RdrName])-partition_nwcs free_vars@(FKTV { fktv_tys = tys })-  = do { wildcards_enabled <- fmap (xopt LangExt.NamedWildCards) getDynFlags-       ; let (nwcs, no_nwcs) | wildcards_enabled = partition is_wildcard tys-                             | otherwise         = ([], tys)-             free_vars' = free_vars { fktv_tys = no_nwcs }-       ; return (free_vars', nwcs) }+partition_nwcs :: FreeKiTyVars -> RnM ([Located RdrName], FreeKiTyVars)+partition_nwcs free_vars+  = do { wildcards_enabled <- xoptM LangExt.NamedWildCards+       ; return $+           if wildcards_enabled+           then partition is_wildcard free_vars+           else ([], free_vars) }   where      is_wildcard :: Located RdrName -> Bool      is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr))@@ -285,7 +282,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Identifiers starting with an underscore are always parsed as type variables. It is only here in the renamer that we give the special treatment.-See Note [The wildcard story for types] in HsTypes.+See Note [The wildcard story for types] in GHC.Hs.Types.  It's easy!  When we collect the implicitly bound type variables, ready to bring them into scope, and NamedWildCards is on, we partition the@@ -300,19 +297,22 @@ *                                                       * ****************************************************** -} -rnHsSigType :: HsDocContext -> LHsSigType GhcPs+rnHsSigType :: HsDocContext+            -> TypeOrKind+            -> LHsSigType GhcPs             -> RnM (LHsSigType GhcRn, FreeVars) -- Used for source-language type signatures -- that cannot have wildcards-rnHsSigType ctx (HsIB { hsib_body = hs_ty })+rnHsSigType ctx level (HsIB { hsib_body = hs_ty })   = do { traceRn "rnHsSigType" (ppr hs_ty)        ; vars <- extractFilteredRdrTyVarsDups hs_ty        ; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) vars $ \ vars ->-    do { (body', fvs) <- rnLHsType ctx hs_ty+    do { (body', fvs) <- rnLHsTyKi (mkTyKiEnv ctx level RnTypeBody) hs_ty+        ; return ( HsIB { hsib_ext = vars                        , hsib_body = body' }                 , fvs ) } }-rnHsSigType _ (XHsImplicitBndrs _) = panic "rnHsSigType"+rnHsSigType _ _ (XHsImplicitBndrs nec) = noExtCon nec  rnImplicitBndrs :: Bool    -- True <=> bring into scope any free type variables                            -- E.g.  f :: forall a. a->b@@ -326,51 +326,20 @@                 -> ([Name] -> RnM (a, FreeVars))                 -> RnM (a, FreeVars) rnImplicitBndrs bind_free_tvs-                fvs_with_dups@(FKTV { fktv_kis = kvs_with_dups-                                    , fktv_tys = tvs_with_dups })+                fvs_with_dups                 thing_inside-  = do { let FKTV kvs tvs = rmDupsInRdrTyVars fvs_with_dups-             real_tvs | bind_free_tvs = tvs+  = do { let fvs = nubL fvs_with_dups+             real_fvs | bind_free_tvs = fvs                       | otherwise     = []-             -- We always bind over free /kind/ variables.-             -- Bind free /type/ variables only if there is no-             -- explicit forall.  E.g.-             --    f :: Proxy (a :: k) -> b-             --         Quantify over {k} and {a,b}-             --    g :: forall a. Proxy (a :: k) -> b-             --         Quantify over {k} and {}-             -- Note that we always do the implicit kind-quantification-             -- but, rather arbitrarily, we switch off the type-quantification-             -- if there is an explicit forall -       ; traceRn "rnImplicitBndrs" (vcat [ ppr kvs, ppr tvs, ppr real_tvs ])--       ; whenWOptM Opt_WarnImplicitKindVars $-         unless (bind_free_tvs || null kvs) $-         addWarnAt (Reason Opt_WarnImplicitKindVars) (getLoc (head kvs)) $-         implicit_kind_vars_msg kvs+       ; traceRn "rnImplicitBndrs" $+         vcat [ ppr fvs_with_dups, ppr fvs, ppr real_fvs ]         ; loc <- getSrcSpanM-          -- NB: kinds before tvs, as mandated by-          -- Note [Ordering of implicit variables]-       ; vars <- mapM (newLocalBndrRn . cL loc . unLoc) (kvs ++ real_tvs)--       ; traceRn "checkMixedVars2" $-           vcat [ text "kvs_with_dups" <+> ppr kvs_with_dups-                , text "tvs_with_dups" <+> ppr tvs_with_dups ]+       ; vars <- mapM (newLocalBndrRn . cL loc . unLoc) real_fvs         ; bindLocalNamesFV vars $          thing_inside vars }-  where-    implicit_kind_vars_msg kvs =-      vcat [ text "An explicit" <+> quotes (text "forall") <+>-             text "was used, but the following kind variables" <+>-             text "are not quantified:" <+>-             hsep (punctuate comma (map (quotes . ppr) kvs))-           , text "Despite this fact, GHC will introduce them into scope," <+>-             text "but it will stop doing so in the future."-           , text "Suggested fix: add" <+>-             quotes (text "forall" <+> hsep (map ppr kvs) <> char '.') ]  {- ****************************************************** *                                                       *@@ -388,7 +357,7 @@ when (1) they are in a type signature not beginning with "forall" or (2) in any qualified type T => R. We are phasing out (2) since it leads to inconsistencies-(Trac #4426):+(#4426):  data A = A (a -> a)           is an error data A = A (Eq a => a -> a)   binds "a"@@ -517,20 +486,21 @@  rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) -rnHsTyKi env ty@(HsForAllTy { hst_bndrs = tyvars, hst_body  = tau })+rnHsTyKi env ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars+                            , hst_body = tau })   = do { checkPolyKinds env ty        ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty)                            Nothing tyvars $ \ tyvars' ->     do { (tau',  fvs) <- rnLHsTyKi env tau-       ; return ( HsForAllTy { hst_xforall = noExt, hst_bndrs = tyvars'-                             , hst_body =  tau' }+       ; return ( HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField+                             , hst_bndrs = tyvars' , hst_body =  tau' }                 , fvs) } }  rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })   = do { checkPolyKinds env ty  -- See Note [QualTy in kinds]        ; (ctxt', fvs1) <- rnTyKiContext env lctxt        ; (tau',  fvs2) <- rnLHsTyKi env tau-       ; return (HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt'+       ; return (HsQualTy { hst_xqual = noExtField, hst_ctxt = ctxt'                           , hst_body =  tau' }                 , fvs1 `plusFV` fvs2) } @@ -543,7 +513,7 @@            -- Any type variable at the kind level is illegal without the use            -- of PolyKinds (see #14710)        ; name <- rnTyVar env rdr_name-       ; return (HsTyVar noExt ip (cL loc name), unitFV name) }+       ; return (HsTyVar noExtField ip (cL loc name), unitFV name) }  rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2)   = setSrcSpan (getLoc l_op) $@@ -551,23 +521,23 @@         ; fix   <- lookupTyFixityRn l_op'         ; (ty1', fvs2) <- rnLHsTyKi env ty1         ; (ty2', fvs3) <- rnLHsTyKi env ty2-        ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExt t1 l_op' t2)+        ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExtField t1 l_op' t2)                                (unLoc l_op') fix ty1' ty2'         ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }  rnHsTyKi env (HsParTy _ ty)   = do { (ty', fvs) <- rnLHsTyKi env ty-       ; return (HsParTy noExt ty', fvs) }+       ; return (HsParTy noExtField ty', fvs) }  rnHsTyKi env (HsBangTy _ b ty)   = do { (ty', fvs) <- rnLHsTyKi env ty-       ; return (HsBangTy noExt b ty', fvs) }+       ; return (HsBangTy noExtField b ty', fvs) }  rnHsTyKi env ty@(HsRecTy _ flds)   = do { let ctxt = rtke_ctxt env        ; fls          <- get_fields ctxt        ; (flds', fvs) <- rnConDeclFields ctxt fls flds-       ; return (HsRecTy noExt flds', fvs) }+       ; return (HsRecTy noExtField flds', fvs) }   where     get_fields (ConDeclCtx names)       = concatMapM (lookupConstructorFields . unLoc) names@@ -584,7 +554,7 @@         -- when we find return :: forall m. Monad m -> forall a. a -> m a          -- Check for fixity rearrangements-       ; res_ty <- mkHsOpTyRn (HsFunTy noExt) funTyConName funTyFixity ty1' ty2'+       ; res_ty <- mkHsOpTyRn (HsFunTy noExtField) funTyConName funTyFixity ty1' ty2'        ; return (res_ty, fvs1 `plusFV` fvs2) }  rnHsTyKi env listTy@(HsListTy _ ty)@@ -592,15 +562,15 @@        ; when (not data_kinds && isRnKindLevel env)               (addErr (dataKindsErr env listTy))        ; (ty', fvs) <- rnLHsTyKi env ty-       ; return (HsListTy noExt ty', fvs) }+       ; return (HsListTy noExtField ty', fvs) }  rnHsTyKi env t@(HsKindSig _ ty k)   = do { checkPolyKinds env t        ; kind_sigs_ok <- xoptM LangExt.KindSignatures        ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty)-       ; (ty', fvs1) <- rnLHsTyKi env ty-       ; (k', fvs2)  <- rnLHsTyKi (env { rtke_level = KindLevel }) k-       ; return (HsKindSig noExt ty' k', fvs1 `plusFV` fvs2) }+       ; (ty', lhs_fvs) <- rnLHsTyKi env ty+       ; (k', sig_fvs)  <- rnLHsTyKi (env { rtke_level = KindLevel }) k+       ; return (HsKindSig noExtField ty' k', lhs_fvs `plusFV` sig_fvs) }  -- Unboxed tuples are allowed to have poly-typed arguments.  These -- sometimes crop up as a result of CPR worker-wrappering dictionaries.@@ -609,14 +579,14 @@        ; when (not data_kinds && isRnKindLevel env)               (addErr (dataKindsErr env tupleTy))        ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys-       ; return (HsTupleTy noExt tup_con tys', fvs) }+       ; return (HsTupleTy noExtField tup_con tys', fvs) }  rnHsTyKi env sumTy@(HsSumTy _ tys)   = do { data_kinds <- xoptM LangExt.DataKinds        ; when (not data_kinds && isRnKindLevel env)               (addErr (dataKindsErr env sumTy))        ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys-       ; return (HsSumTy noExt tys', fvs) }+       ; return (HsSumTy noExtField tys', fvs) }  -- Ensure that a type-level integer is nonnegative (#8306, #8412) rnHsTyKi env tyLit@(HsTyLit _ t)@@ -624,7 +594,7 @@        ; unless data_kinds (addErr (dataKindsErr env tyLit))        ; when (negLit t) (addErr negLitErr)        ; checkPolyKinds env tyLit-       ; return (HsTyLit noExt t, emptyFVs) }+       ; return (HsTyLit noExtField t, emptyFVs) }   where     negLit (HsStrTy _ _) = False     negLit (HsNumTy _ i) = i < 0@@ -633,7 +603,7 @@ rnHsTyKi env (HsAppTy _ ty1 ty2)   = do { (ty1', fvs1) <- rnLHsTyKi env ty1        ; (ty2', fvs2) <- rnLHsTyKi env ty2-       ; return (HsAppTy noExt ty1' ty2', fvs1 `plusFV` fvs2) }+       ; return (HsAppTy noExtField ty1' ty2', fvs1 `plusFV` fvs2) }  rnHsTyKi env (HsAppKindTy l ty k)   = do { kind_app <- xoptM LangExt.TypeApplications@@ -645,10 +615,10 @@ rnHsTyKi env t@(HsIParamTy _ n ty)   = do { notInKinds env t        ; (ty', fvs) <- rnLHsTyKi env ty-       ; return (HsIParamTy noExt n ty', fvs) }+       ; return (HsIParamTy noExtField n ty', fvs) }  rnHsTyKi _ (HsStarTy _ isUni)-  = return (HsStarTy noExt isUni, emptyFVs)+  = return (HsStarTy noExtField isUni, emptyFVs)  rnHsTyKi _ (HsSpliceTy _ sp)   = rnSpliceType sp@@ -656,7 +626,7 @@ rnHsTyKi env (HsDocTy _ ty haddock_doc)   = do { (ty', fvs) <- rnLHsTyKi env ty        ; haddock_doc' <- rnLHsDoc haddock_doc-       ; return (HsDocTy noExt ty' haddock_doc', fvs) }+       ; return (HsDocTy noExtField ty' haddock_doc', fvs) }  rnHsTyKi _ (XHsType (NHsCoreTy ty))   = return (XHsType (NHsCoreTy ty), emptyFVs)@@ -668,18 +638,18 @@        ; data_kinds <- xoptM LangExt.DataKinds        ; unless data_kinds (addErr (dataKindsErr env ty))        ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys-       ; return (HsExplicitListTy noExt ip tys', fvs) }+       ; return (HsExplicitListTy noExtField ip tys', fvs) }  rnHsTyKi env ty@(HsExplicitTupleTy _ tys)   = do { checkPolyKinds env ty        ; data_kinds <- xoptM LangExt.DataKinds        ; unless data_kinds (addErr (dataKindsErr env ty))        ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys-       ; return (HsExplicitTupleTy noExt tys', fvs) }+       ; return (HsExplicitTupleTy noExtField tys', fvs) }  rnHsTyKi env (HsWildCardTy _)   = do { checkAnonWildCard env-       ; return (HsWildCardTy noExt, emptyFVs) }+       ; return (HsWildCardTy noExtField, emptyFVs) }  -------------- rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name@@ -728,8 +698,8 @@            | otherwise            = case rtke_what env of                RnTypeBody      -> Nothing-               RnConstraint    -> Just constraint_msg                RnTopConstraint -> Just constraint_msg+               RnConstraint    -> Just constraint_msg      constraint_msg = hang                          (notAllowed pprAnonWildCard <+> text "in a constraint")@@ -749,7 +719,10 @@            | otherwise            = case rtke_what env of                RnTypeBody      -> Nothing   -- Allowed-               RnTopConstraint -> Nothing   -- Allowed+               RnTopConstraint -> Nothing   -- Allowed; e.g.+                  -- f :: (Eq _a) => _a -> Int+                  -- g :: (_a, _b) => T _a _b -> Int+                  -- The named tyvars get filled in from elsewhere                RnConstraint    -> Just constraint_msg     constraint_msg = notAllowed (ppr name) <+> text "in a constraint" @@ -766,6 +739,7 @@        FamPatCtx {}        -> True   -- Not named wildcards though        GHCiCtx {}          -> True        HsTypeCtx {}        -> True+       StandaloneKindSigCtx {} -> False  -- See Note [Wildcards in standalone kind signatures] in GHC/Hs/Decls        _                   -> False  @@ -835,7 +809,7 @@                   -- The Bool is True <=> all kind variables used in the                   -- kind signature are bound on the left.  Reason:                   -- the last clause of Note [CUSKs: Complete user-supplied-                  -- kind signatures] in HsDecls+                  -- kind signatures] in GHC.Hs.Decls               -> RnM (b, FreeVars)  -- See Note [bindHsQTyVars examples]@@ -857,11 +831,7 @@                                  -- body kvs, as mandated by                                  -- Note [Ordering of implicit variables]              implicit_kvs = filter_occs bndrs kv_occs-             -- dep_bndrs is the subset of bndrs that are dependent-             --   i.e. appear in bndr/body_kv_occs-             -- Can't use implicit_kvs because we've deleted bndrs from that!-             dep_bndrs = filter (`elemRdr` kv_occs) bndrs-             del       = deleteBys eqLocated+             del          = deleteBys eqLocated              all_bound_on_lhs = null ((body_kv_occs `del` bndrs) `del` bndr_kv_occs)         ; traceRn "checkMixedVars3" $@@ -876,10 +846,7 @@        ; bindLocalNamesFV implicit_kv_nms                     $          bindLHsTyVarBndrs doc mb_in_doc mb_assoc hs_tv_bndrs $ \ rn_bndrs ->     do { traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs)-       ; dep_bndr_nms <- mapM (lookupLocalOccRn . unLoc) dep_bndrs-       ; thing_inside (HsQTvs { hsq_ext = HsQTvsRn-                                   { hsq_implicit  = implicit_kv_nms-                                   , hsq_dependent = mkNameSet dep_bndr_nms }+       ; thing_inside (HsQTvs { hsq_ext = implicit_kv_nms                               , hsq_explicit  = rn_bndrs })                       all_bound_on_lhs } } @@ -914,9 +881,6 @@  * We want to quantify add implicit bindings for implicit_kvs -* The "dependent" bndrs (hsq_dependent) are the subset of-  bndrs that are free in bndr_kv_occs or body_kv_occs- * If implicit_body_kvs is non-empty, then there is a kind variable   mentioned in the kind signature that is not bound "on the left".   That's one of the rules for a CUSK, so we pass that info on@@ -1042,7 +1006,7 @@                $ thing_inside (cL loc (KindedTyVar x (cL lv tv_nm) kind'))            ; return (b, fvs1 `plusFV` fvs2) } -bindLHsTyVarBndr _ _ (dL->L _ (XTyVarBndr{})) _ = panic "bindLHsTyVarBndr"+bindLHsTyVarBndr _ _ (dL->L _ (XTyVarBndr nec)) _ = noExtCon nec bindLHsTyVarBndr _ _ _ _ = panic "bindLHsTyVarBndr: Impossible Match"                              -- due to #15884 @@ -1084,7 +1048,7 @@   = do { let new_names = map (fmap lookupField) names        ; (new_ty, fvs) <- rnLHsTyKi env ty        ; new_haddock_doc <- rnMbLHsDoc haddock_doc-       ; return (cL l (ConDeclField noExt new_names new_ty new_haddock_doc)+       ; return (cL l (ConDeclField noExtField new_names new_ty new_haddock_doc)                 , fvs) }   where     lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn@@ -1093,8 +1057,8 @@       where         lbl = occNameFS $ rdrNameOcc rdr         fl  = expectJust "rnField" $ lookupFsEnv fl_env lbl-    lookupField (XFieldOcc{}) = panic "rnField"-rnField _ _ (dL->L _ (XConDeclField _)) = panic "rnField"+    lookupField (XFieldOcc nec) = noExtCon nec+rnField _ _ (dL->L _ (XConDeclField nec)) = noExtCon nec rnField _ _ _ = panic "rnField: Impossible Match"                              -- due to #15884 @@ -1130,15 +1094,15 @@            -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn            -> RnM (HsType GhcRn) -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsOpTy noExt ty21 op2 ty22))+mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsOpTy noExtField ty21 op2 ty22))   = do  { fix2 <- lookupTyFixityRn op2         ; mk_hs_op_ty mk1 pp_op1 fix1 ty1-                      (\t1 t2 -> HsOpTy noExt t1 op2 t2)+                      (\t1 t2 -> HsOpTy noExtField t1 op2 t2)                       (unLoc op2) fix2 ty21 ty22 loc2 }  mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsFunTy _ ty21 ty22))   = mk_hs_op_ty mk1 pp_op1 fix1 ty1-                (HsFunTy noExt) funTyConName funTyFixity ty21 ty22 loc2+                (HsFunTy noExtField) funTyConName funTyFixity ty21 ty22 loc2  mkHsOpTyRn mk1 _ _ ty1 ty2              -- Default case, no rearrangment   = return (mk1 ty1 ty2)@@ -1190,7 +1154,7 @@    | associate_right   = do new_e <- mkOpAppRn neg_arg op2 fix2 e2-       return (NegApp noExt (cL loc' new_e) neg_name)+       return (NegApp noExtField (cL loc' new_e) neg_name)   where     loc' = combineLocs neg_arg e2     (nofix_error, associate_right) = compareFixity negateFixity fix2@@ -1252,7 +1216,7 @@            -> RnM (HsExpr (GhcPass id)) mkNegAppRn neg_arg neg_name   = ASSERT( not_op_app (unLoc neg_arg) )-    return (NegApp noExt neg_arg neg_name)+    return (NegApp noExtField neg_arg neg_name)  not_op_app :: HsExpr id -> Bool not_op_app (OpApp {}) = False@@ -1276,7 +1240,7 @@    | associate_right   = do new_c <- mkOpFormRn a12 op2 fix2 a2-       return (HsCmdArrForm noExt op1 f (Just fix1)+       return (HsCmdArrForm noExtField op1 f (Just fix1)                [a11, cL loc (HsCmdTop [] (cL loc new_c))])         -- TODO: locs are wrong   where@@ -1284,7 +1248,7 @@  --      Default case mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment-  = return (HsCmdArrForm noExt op Infix (Just fix) [arg1, arg2])+  = return (HsCmdArrForm noExtField op Infix (Just fix) [arg1, arg2])   --------------------------------------@@ -1338,7 +1302,7 @@         -- but the second eqn has no args (an error, but not discovered         -- until the type checker).  So we don't want to crash on the         -- second eqn.-checkPrecMatch _ (XMatchGroup {}) = panic "checkPrecMatch"+checkPrecMatch _ (XMatchGroup nec) = noExtCon nec  checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) () checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do@@ -1380,7 +1344,7 @@  -- | Look up the fixity for an operator name.  Be careful to use -- 'lookupFieldFixityRn' for (possibly ambiguous) record fields--- (see Trac #13132).+-- (see #13132). lookupFixityOp :: OpName -> RnM Fixity lookupFixityOp (NormalOp n)  = lookupFixityRn n lookupFixityOp NegateOp      = lookupFixityRn negateName@@ -1474,8 +1438,7 @@  Note [Kind and type-variable binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In a type signature we may implicitly bind type variable and, more-recently, kind variables.  For example:+In a type signature we may implicitly bind type/kind variables. For example:   *   f :: a -> a       f = ...     Here we need to find the free type variables of (a -> a),@@ -1493,42 +1456,11 @@   *   type instance F (T (a :: Maybe k)) = ...a...k...     Here we want to constrain the kind of 'a', and bind 'k'. -In general we want to walk over a type, and find-  * Its free type variables-  * The free kind variables of any kind signatures in the type--Hence we return a pair (kind-vars, type vars)-(See Note [HsBSig binder lists] in HsTypes.)-Moreover, we preserve the left-to-right order of the first occurrence of each-variable, while preserving dependency order.-(See Note [Ordering of implicit variables].)--Most clients of this code just want to know the kind/type vars, without-duplicates. The function rmDupsInRdrTyVars removes duplicates. That function-also makes sure that no variable is reported as both a kind var and-a type var, preferring kind vars. Why kind vars? Consider this:-- foo :: forall (a :: k). Proxy k -> Proxy a -> ...--Should that be accepted?--Normally, if a type signature has an explicit forall, it must list *all*-tyvars mentioned in the type. But there's an exception for tyvars mentioned in-a kind, as k is above. Note that k is also used "as a type variable", as the-argument to the first Proxy. So, do we consider k to be type-variable-like and-require it in the forall? Or do we consider k to be kind-variable-like and not-require it?--It's not just in type signatures: kind variables are implicitly brought into-scope in a variety of places. Should vars used at both the type level and kind-level be treated this way?+To do that, we need to walk over a type and find its free type/kind variables.+We preserve the left-to-right order of each variable occurrence.+See Note [Ordering of implicit variables]. -GHC indeed allows kind variables to be brought into scope implicitly even when-the kind variable is also used as a type variable. Thus, we must prefer to keep-a variable listed as a kind var in rmDupsInRdrTyVars. If we kept it as a type-var, then this would prevent it from being implicitly quantified (see-rnImplicitBndrs). In the `foo` example above, that would have the consequence-of the k in Proxy k being reported as out of scope.+Clients of this code can remove duplicates with nubL.  Note [Ordering of implicit variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1558,30 +1490,98 @@  Implicitly bound variables are collected by any function which returns a FreeKiTyVars, FreeKiTyVarsWithDups, or FreeKiTyVarsNoDups, which notably-includes the `extract-` family of functions (extractHsTysRdrTyVars,+includes the `extract-` family of functions (extractHsTysRdrTyVarsDups, extractHsTyVarBndrsKVs, etc.). These functions thus promise to keep left-to-right ordering.-Look for pointers to this note to see the places where the action happens. -Note that we also maintain this ordering in kind signatures. Even though-there's no visible kind application (yet), having implicit variables be-quantified in left-to-right order in kind signatures is nice since:+Note [Implicit quantification in type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We typically bind type/kind variables implicitly when they are in a kind+annotation on the LHS, for example: -* It's consistent with the treatment for type signatures.-* It can affect how types are displayed with -fprint-explicit-kinds (see-  #15568 for an example), which is a situation where knowing the order in-  which implicit variables are quantified can be useful.-* In the event that visible kind application is implemented, the order in-  which we would expect implicit variables to be ordered in kinds will have-  already been established.+  data Proxy (a :: k) = Proxy+  type KindOf (a :: k) = k++Here 'k' is in the kind annotation of a type variable binding, KindedTyVar, and+we want to implicitly quantify over it.  This is easy: just extract all free+variables from the kind signature. That's what we do in extract_hs_tv_bndrs_kvs++By contrast, on the RHS we can't simply collect *all* free variables. Which of+the following are allowed?++  type TySyn1 = a :: Type+  type TySyn2 = 'Nothing :: Maybe a+  type TySyn3 = 'Just ('Nothing :: Maybe a)+  type TySyn4 = 'Left a :: Either Type a++After some design deliberations (see non-taken alternatives below), the answer+is to reject TySyn1 and TySyn3, but allow TySyn2 and TySyn4, at least for now.+We implicitly quantify over free variables of the outermost kind signature, if+one exists:++  * In TySyn1, the outermost kind signature is (:: Type), and it does not have+    any free variables.+  * In TySyn2, the outermost kind signature is (:: Maybe a), it contains a+    free variable 'a', which we implicitly quantify over.+  * In TySyn3, there is no outermost kind signature. The (:: Maybe a) signature+    is hidden inside 'Just.+  * In TySyn4, the outermost kind signature is (:: Either Type a), it contains+    a free variable 'a', which we implicitly quantify over. That is why we can+    also use it to the left of the double colon: 'Left a++The logic resides in extractHsTyRdrTyVarsKindVars. We use it both for type+synonyms and type family instances.++This is something of a stopgap solution until we can explicitly bind invisible+type/kind variables:++  type TySyn3 :: forall a. Maybe a+  type TySyn3 @a = 'Just ('Nothing :: Maybe a)++Note [Implicit quantification in type synonyms: non-taken alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Alternative I: No quantification+--------------------------------+We could offer no implicit quantification on the RHS, accepting none of the+TySyn<N> examples. The user would have to bind the variables explicitly:++  type TySyn1 a = a :: Type+  type TySyn2 a = 'Nothing :: Maybe a+  type TySyn3 a = 'Just ('Nothing :: Maybe a)+  type TySyn4 a = 'Left a :: Either Type a++However, this would mean that one would have to specify 'a' at call sites every+time, which could be undesired.++Alternative II: Indiscriminate quantification+---------------------------------------------+We could implicitly quantify over all free variables on the RHS just like we do+on the LHS. Then we would infer the following kinds:++  TySyn1 :: forall {a}. Type+  TySyn2 :: forall {a}. Maybe a+  TySyn3 :: forall {a}. Maybe (Maybe a)+  TySyn4 :: forall {a}. Either Type a++This would work fine for TySyn<2,3,4>, but TySyn1 is clearly bogus: the variable+is free-floating, not fixed by anything.++Alternative III: reportFloatingKvs+----------------------------------+We could augment Alternative II by hunting down free-floating variables during+type checking. While viable, this would mean we'd end up accepting this:++  data Prox k (a :: k)+  type T = Prox k+ -}  -- See Note [Kind and type-variable binders] -- These lists are guaranteed to preserve left-to-right ordering of -- the types the variables were extracted from. See also -- Note [Ordering of implicit variables].-data FreeKiTyVars = FKTV { fktv_kis    :: [Located RdrName]-                         , fktv_tys    :: [Located RdrName] }+type FreeKiTyVars = [Located RdrName]  -- | A 'FreeKiTyVars' list that is allowed to have duplicate variables. type FreeKiTyVarsWithDups = FreeKiTyVars@@ -1589,94 +1589,70 @@ -- | A 'FreeKiTyVars' list that contains no duplicate variables. type FreeKiTyVarsNoDups   = FreeKiTyVars -instance Outputable FreeKiTyVars where-  ppr (FKTV { fktv_kis = kis, fktv_tys = tys}) = ppr (kis, tys)--emptyFKTV :: FreeKiTyVarsNoDups-emptyFKTV = FKTV { fktv_kis = [], fktv_tys = [] }--freeKiTyVarsAllVars :: FreeKiTyVars -> [Located RdrName]-freeKiTyVarsAllVars (FKTV { fktv_kis = kvs, fktv_tys = tvs }) = kvs ++ tvs--freeKiTyVarsKindVars :: FreeKiTyVars -> [Located RdrName]-freeKiTyVarsKindVars = fktv_kis--freeKiTyVarsTypeVars :: FreeKiTyVars -> [Located RdrName]-freeKiTyVarsTypeVars = fktv_tys- filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars-filterInScope rdr_env (FKTV { fktv_kis = kis, fktv_tys = tys })-  = FKTV { fktv_kis = filterOut in_scope kis-         , fktv_tys = filterOut in_scope tys }-  where-    in_scope = inScope rdr_env . unLoc+filterInScope rdr_env = filterOut (inScope rdr_env . unLoc) +filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars+filterInScopeM vars+  = do { rdr_env <- getLocalRdrEnv+       ; return (filterInScope rdr_env vars) }+ inScope :: LocalRdrEnv -> RdrName -> Bool inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env --- | 'extractHsTyRdrTyVars' finds the---        free (kind, type) variables of an 'HsType'--- or the free (sort, kind) variables of an 'HsKind'.--- It's used when making the @forall@s explicit.--- Does not return any wildcards.--- When the same name occurs multiple times in the types, only the first--- occurrence is returned.--- See Note [Kind and type-variable binders]-- extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups-extract_tyarg (HsValArg ty) acc = extract_lty TypeLevel ty acc-extract_tyarg (HsTypeArg _ ki) acc = extract_lty KindLevel ki acc+extract_tyarg (HsValArg ty) acc = extract_lty ty acc+extract_tyarg (HsTypeArg _ ki) acc = extract_lty ki acc extract_tyarg (HsArgPar _) acc = acc  extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups extract_tyargs args acc = foldr extract_tyarg acc args  extractHsTyArgRdrKiTyVarsDup :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups-extractHsTyArgRdrKiTyVarsDup args = extract_tyargs args emptyFKTV+extractHsTyArgRdrKiTyVarsDup args+  = extract_tyargs args [] +-- | 'extractHsTyRdrTyVars' finds the type/kind variables+--                          of a HsType/HsKind.+-- It's used when making the @forall@s explicit.+-- When the same name occurs multiple times in the types, only the first+-- occurrence is returned.+-- See Note [Kind and type-variable binders] extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVarsNoDups extractHsTyRdrTyVars ty-  = rmDupsInRdrTyVars (extractHsTyRdrTyVarsDups ty)+  = nubL (extractHsTyRdrTyVarsDups ty) --- | 'extractHsTyRdrTyVarsDups' find the---        free (kind, type) variables of an 'HsType'--- or the free (sort, kind) variables of an 'HsKind'.+-- | 'extractHsTyRdrTyVarsDups' finds the type/kind variables+--                              of a HsType/HsKind. -- It's used when making the @forall@s explicit.--- Does not return any wildcards. -- When the same name occurs multiple times in the types, all occurrences -- are returned. extractHsTyRdrTyVarsDups :: LHsType GhcPs -> FreeKiTyVarsWithDups extractHsTyRdrTyVarsDups ty-  = extract_lty TypeLevel ty emptyFKTV+  = extract_lty ty [] --- | Extracts the free kind variables (but not the type variables) of an--- 'HsType'. Does not return any wildcards.+-- | Extracts the free type/kind variables from the kind signature of a HsType.+--   This is used to implicitly quantify over @k@ in @type T = Nothing :: Maybe k@. -- When the same name occurs multiple times in the type, only the first -- occurrence is returned, and the left-to-right order of variables is -- preserved. -- See Note [Kind and type-variable binders] and--- Note [Ordering of implicit variables].-extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> [Located RdrName]-extractHsTyRdrTyVarsKindVars ty-  = freeKiTyVarsKindVars (extractHsTyRdrTyVars ty)---- | Extracts free type and kind variables from types in a list.--- When the same name occurs multiple times in the types, only the first--- occurrence is returned and the rest is filtered out.--- See Note [Kind and type-variable binders]-extractHsTysRdrTyVars :: [LHsType GhcPs] -> FreeKiTyVarsNoDups-extractHsTysRdrTyVars tys-  = rmDupsInRdrTyVars (extractHsTysRdrTyVarsDups tys)+--     Note [Ordering of implicit variables] and+--     Note [Implicit quantification in type synonyms].+extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> FreeKiTyVarsNoDups+extractHsTyRdrTyVarsKindVars (unLoc -> ty) =+  case ty of+    HsParTy _ ty -> extractHsTyRdrTyVarsKindVars ty+    HsKindSig _ _ ki -> extractHsTyRdrTyVars ki+    _ -> []  -- | Extracts free type and kind variables from types in a list. -- When the same name occurs multiple times in the types, all occurrences -- are returned. extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> FreeKiTyVarsWithDups extractHsTysRdrTyVarsDups tys-  = extract_ltys TypeLevel tys emptyFKTV+  = extract_ltys tys [] -extractHsTyVarBndrsKVs :: [LHsTyVarBndr GhcPs] -> [Located RdrName] -- Returns the free kind variables of any explictly-kinded binders, returning -- variable occurrences in left-to-right order. -- See Note [Ordering of implicit variables].@@ -1684,124 +1660,76 @@ --     However duplicates are removed --     E.g. given  [k1, a:k1, b:k2] --          the function returns [k1,k2], even though k1 is bound here+extractHsTyVarBndrsKVs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVarsNoDups extractHsTyVarBndrsKVs tv_bndrs   = nubL (extract_hs_tv_bndrs_kvs tv_bndrs) --- | Removes multiple occurrences of the same name from FreeKiTyVars. If a--- variable occurs as both a kind and a type variable, only keep the occurrence--- as a kind variable.--- See also Note [Kind and type-variable binders]-rmDupsInRdrTyVars :: FreeKiTyVarsWithDups -> FreeKiTyVarsNoDups-rmDupsInRdrTyVars (FKTV { fktv_kis = kis, fktv_tys = tys })-  = FKTV { fktv_kis = kis'-         , fktv_tys = nubL (filterOut (`elemRdr` kis') tys) }-  where-    kis' = nubL kis--extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName] -- Returns the free kind variables in a type family result signature, returning -- variable occurrences in left-to-right order. -- See Note [Ordering of implicit variables].+extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName] extractRdrKindSigVars (dL->L _ resultSig)-  | KindSig _ k                              <- resultSig = kindRdrNameFromSig k-  | TyVarSig _ (dL->L _ (KindedTyVar _ _ k)) <- resultSig = kindRdrNameFromSig k+  | KindSig _ k                              <- resultSig = extractHsTyRdrTyVars k+  | TyVarSig _ (dL->L _ (KindedTyVar _ _ k)) <- resultSig = extractHsTyRdrTyVars k   | otherwise =  []-    where-      kindRdrNameFromSig k = freeKiTyVarsAllVars (extractHsTyRdrTyVars k) -extractDataDefnKindVars :: HsDataDefn GhcPs -> [Located RdrName]--- Get the scoped kind variables mentioned free in the constructor decls--- Eg: data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)---     Here k should scope over the whole definition+-- Get type/kind variables mentioned in the kind signature, preserving+-- left-to-right order and without duplicates: ----- However, do NOT collect free kind vars from the deriving clauses:--- Eg: (Trac #14331)    class C p q---                      data D = D deriving ( C (a :: k) )---     Here k should /not/ scope over the whole definition.  We intend---     this to elaborate to:---         class C @k1 @k2 (p::k1) (q::k2)---         data D = D---         instance forall k (a::k). C @k @* a D where ...+--  * data T a (b :: k1) :: k2 -> k1 -> k2 -> Type   -- result: [k2,k1]+--  * data T a (b :: k1)                             -- result: [] ----- This returns variable occurrences in left-to-right order. -- See Note [Ordering of implicit variables].-extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig-                                    , dd_cons = cons })-  = (nubL . freeKiTyVarsKindVars) $-    (extract_lctxt TypeLevel ctxt  $-     extract_mb extract_lkind ksig $-     foldr (extract_con . unLoc) emptyFKTV cons)-  where-    extract_con (ConDeclGADT { }) acc = acc-    extract_con (ConDeclH98 { con_ex_tvs = ex_tvs-                            , con_mb_cxt = ctxt, con_args = args }) acc-      = extract_hs_tv_bndrs ex_tvs acc $-        extract_mlctxt ctxt            $-        extract_ltys TypeLevel (hsConDeclArgTys args) emptyFKTV-    extract_con (XConDecl { }) _ = panic "extractDataDefnKindVars"-extractDataDefnKindVars (XHsDataDefn _) = panic "extractDataDefnKindVars"--extract_mlctxt :: Maybe (LHsContext GhcPs)-               -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups-extract_mlctxt Nothing     acc = acc-extract_mlctxt (Just ctxt) acc = extract_lctxt TypeLevel ctxt acc+extractDataDefnKindVars :: HsDataDefn GhcPs ->  FreeKiTyVarsNoDups+extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig })+  = maybe [] extractHsTyRdrTyVars ksig+extractDataDefnKindVars (XHsDataDefn nec) = noExtCon nec -extract_lctxt :: TypeOrKind-              -> LHsContext GhcPs+extract_lctxt :: LHsContext GhcPs               -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups-extract_lctxt t_or_k ctxt = extract_ltys t_or_k (unLoc ctxt)+extract_lctxt ctxt = extract_ltys (unLoc ctxt) -extract_ltys :: TypeOrKind-             -> [LHsType GhcPs]+extract_ltys :: [LHsType GhcPs]              -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups-extract_ltys t_or_k tys acc = foldr (extract_lty t_or_k) acc tys--extract_mb :: (a -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)-           -> Maybe a-           -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups-extract_mb _ Nothing  acc = acc-extract_mb f (Just x) acc = f x acc--extract_lkind :: LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars-extract_lkind = extract_lty KindLevel+extract_ltys tys acc = foldr extract_lty acc tys -extract_lty :: TypeOrKind -> LHsType GhcPs+extract_lty :: LHsType GhcPs             -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups-extract_lty t_or_k (dL->L _ ty) acc+extract_lty (dL->L _ ty) acc   = case ty of-      HsTyVar _ _  ltv            -> extract_tv t_or_k ltv acc-      HsBangTy _ _ ty             -> extract_lty t_or_k ty acc-      HsRecTy _ flds              -> foldr (extract_lty t_or_k+      HsTyVar _ _  ltv            -> extract_tv ltv acc+      HsBangTy _ _ ty             -> extract_lty ty acc+      HsRecTy _ flds              -> foldr (extract_lty                                             . cd_fld_type . unLoc) acc                                            flds-      HsAppTy _ ty1 ty2           -> extract_lty t_or_k ty1 $-                                     extract_lty t_or_k ty2 acc-      HsAppKindTy _ ty k          -> extract_lty t_or_k ty $-                                     extract_lty KindLevel k acc-      HsListTy _ ty               -> extract_lty t_or_k ty acc-      HsTupleTy _ _ tys           -> extract_ltys t_or_k tys acc-      HsSumTy _ tys               -> extract_ltys t_or_k tys acc-      HsFunTy _ ty1 ty2           -> extract_lty t_or_k ty1 $-                                     extract_lty t_or_k ty2 acc-      HsIParamTy _ _ ty           -> extract_lty t_or_k ty acc-      HsOpTy _ ty1 tv ty2         -> extract_tv t_or_k tv   $-                                     extract_lty t_or_k ty1 $-                                     extract_lty t_or_k ty2 acc-      HsParTy _ ty                -> extract_lty t_or_k ty acc+      HsAppTy _ ty1 ty2           -> extract_lty ty1 $+                                     extract_lty ty2 acc+      HsAppKindTy _ ty k          -> extract_lty ty $+                                     extract_lty k acc+      HsListTy _ ty               -> extract_lty ty acc+      HsTupleTy _ _ tys           -> extract_ltys tys acc+      HsSumTy _ tys               -> extract_ltys tys acc+      HsFunTy _ ty1 ty2           -> extract_lty ty1 $+                                     extract_lty ty2 acc+      HsIParamTy _ _ ty           -> extract_lty ty acc+      HsOpTy _ ty1 tv ty2         -> extract_tv tv $+                                     extract_lty ty1 $+                                     extract_lty ty2 acc+      HsParTy _ ty                -> extract_lty ty acc       HsSpliceTy {}               -> acc  -- Type splices mention no tvs-      HsDocTy _ ty _              -> extract_lty t_or_k ty acc-      HsExplicitListTy _ _ tys    -> extract_ltys t_or_k tys acc-      HsExplicitTupleTy _ tys     -> extract_ltys t_or_k tys acc+      HsDocTy _ ty _              -> extract_lty ty acc+      HsExplicitListTy _ _ tys    -> extract_ltys tys acc+      HsExplicitTupleTy _ tys     -> extract_ltys tys acc       HsTyLit _ _                 -> acc       HsStarTy _ _                -> acc-      HsKindSig _ ty ki           -> extract_lty t_or_k ty $-                                     extract_lkind ki acc+      HsKindSig _ ty ki           -> extract_lty ty $+                                     extract_lty ki acc       HsForAllTy { hst_bndrs = tvs, hst_body = ty }                                   -> extract_hs_tv_bndrs tvs acc $-                                     extract_lty t_or_k ty emptyFKTV+                                     extract_lty ty []       HsQualTy { hst_ctxt = ctxt, hst_body = ty }-                                  -> extract_lctxt t_or_k ctxt $-                                     extract_lty t_or_k ty acc+                                  -> extract_lctxt ctxt $+                                     extract_lty ty acc       XHsType {}                  -> acc       -- We deal with these separately in rnLHsTypeWithWildCards       HsWildCardTy {}             -> acc@@ -1810,7 +1738,7 @@                  -> FreeKiTyVarsWithDups           -- Free in body                  -> FreeKiTyVarsWithDups       -- Free in result extractHsTvBndrs tv_bndrs body_fvs-  = extract_hs_tv_bndrs tv_bndrs emptyFKTV body_fvs+  = extract_hs_tv_bndrs tv_bndrs [] body_fvs  extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs]                     -> FreeKiTyVarsWithDups  -- Accumulator@@ -1820,27 +1748,14 @@ --     'a' is bound by the forall --     'b' is a free type variable --     'e' is a free kind variable-extract_hs_tv_bndrs tv_bndrs-      (FKTV { fktv_kis = acc_kvs,  fktv_tys = acc_tvs })   -- Accumulator-      (FKTV { fktv_kis = body_kvs, fktv_tys = body_tvs })  -- Free in the body-  | null tv_bndrs-  = FKTV { fktv_kis = body_kvs ++ acc_kvs-         , fktv_tys = body_tvs ++ acc_tvs }-  | otherwise-  = FKTV { fktv_kis = filterOut (`elemRdr` tv_bndr_rdrs) all_kv_occs-                      -- NB: delete all tv_bndr_rdrs from bndr_kvs as well-                      -- as body_kvs; see Note [Kind variable scoping]-                      ++ acc_kvs-         , fktv_tys = filterOut (`elemRdr` tv_bndr_rdrs) body_tvs ++ acc_tvs }+extract_hs_tv_bndrs tv_bndrs acc_vars body_vars+  | null tv_bndrs = body_vars ++ acc_vars+  | otherwise = filterOut (`elemRdr` tv_bndr_rdrs) (bndr_vars ++ body_vars) ++ acc_vars+    -- NB: delete all tv_bndr_rdrs from bndr_vars as well as body_vars.+    -- See Note [Kind variable scoping]   where-    bndr_kvs = extract_hs_tv_bndrs_kvs tv_bndrs--    tv_bndr_rdrs, all_kv_occs :: [Located RdrName]+    bndr_vars = extract_hs_tv_bndrs_kvs tv_bndrs     tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs-    all_kv_occs = bndr_kvs ++ body_kvs-       -- We must include both kind variables from the binding as well-       -- as the body of the `forall` type.-       -- See Note [Variables used as both types and kinds].  extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> [Located RdrName] -- Returns the free kind variables of any explictly-kinded binders, returning@@ -1850,17 +1765,14 @@ --     Duplicates are /not/ removed --     E.g. given  [k1, a:k1, b:k2] --          the function returns [k1,k2], even though k1 is bound here-extract_hs_tv_bndrs_kvs tv_bndrs-  = freeKiTyVarsKindVars $        -- There will /be/ no free tyvars!-    foldr extract_lkind emptyFKTV+extract_hs_tv_bndrs_kvs tv_bndrs =+    foldr extract_lty []           [k | (dL->L _ (KindedTyVar _ _ k)) <- tv_bndrs] -extract_tv :: TypeOrKind -> Located RdrName-           -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups-extract_tv t_or_k ltv@(dL->L _ tv) acc@(FKTV kvs tvs)-  | not (isRdrTyVar tv) = acc-  | isTypeLevel t_or_k  = FKTV { fktv_kis = kvs, fktv_tys = ltv : tvs }-  | otherwise           = FKTV { fktv_kis = ltv : kvs, fktv_tys = tvs }+extract_tv :: Located RdrName+           -> [Located RdrName] -> [Located RdrName]+extract_tv tv acc =+  if isRdrTyVar (unLoc tv) then tv:acc else acc  -- Deletes duplicates in a list of Located things. --
compiler/rename/RnUtils.hs view
@@ -14,6 +14,7 @@         addFvRn, mapFvRn, mapMaybeFvRn,         warnUnusedMatches, warnUnusedTypePatterns,         warnUnusedTopBinds, warnUnusedLocalBinds,+        checkUnusedRecordWildcard,         mkFieldEnv,         unknownSubordinateErr, badQualBndrErr, typeAppErr,         HsDocContext(..), pprHsDocContext,@@ -32,7 +33,7 @@  import GhcPrelude -import HsSyn+import GHC.Hs import RdrName import HscTypes import TcEnv@@ -148,7 +149,7 @@   where     check_shadow n         | startsWithUnderscore occ = return ()  -- Do not report shadowing for "_x"-                                                -- See Trac #3262+                                                -- See #3262         | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)]         | otherwise = do { gres' <- filterM is_shadowed_gre gres                          ; complain (map pprNameProvenance gres') }@@ -166,7 +167,7 @@      is_shadowed_gre :: GlobalRdrElt -> RnM Bool         -- Returns False for record selectors that are shadowed, when-        -- punning or wild-cards are on (cf Trac #2723)+        -- punning or wild-cards are on (cf #2723)     is_shadowed_gre gre | isRecFldGRE gre         = do { dflags <- getDynFlags              ; return $ not (xopt LangExt.RecordPuns dflags@@ -222,6 +223,57 @@                                else                 gres          warnUnusedGREs gres' ++-- | Checks to see if we need to warn for -Wunused-record-wildcards or+-- -Wredundant-record-wildcards+checkUnusedRecordWildcard :: SrcSpan+                          -> FreeVars+                          -> Maybe [Name]+                          -> RnM ()+checkUnusedRecordWildcard _ _ Nothing    = return ()+checkUnusedRecordWildcard loc _ (Just [])  = do+  -- Add a new warning if the .. pattern binds no variables+  setSrcSpan loc $ warnRedundantRecordWildcard+checkUnusedRecordWildcard loc fvs (Just dotdot_names) =+  setSrcSpan loc $ warnUnusedRecordWildcard dotdot_names fvs+++-- | Produce a warning when the `..` pattern binds no new+-- variables.+--+-- @+--   data P = P { x :: Int }+--+--   foo (P{x, ..}) = x+-- @+--+-- The `..` here doesn't bind any variables as `x` is already bound.+warnRedundantRecordWildcard :: RnM ()+warnRedundantRecordWildcard =+  whenWOptM Opt_WarnRedundantRecordWildcards+            (addWarn (Reason Opt_WarnRedundantRecordWildcards)+                     redundantWildcardWarning)+++-- | Produce a warning when no variables bound by a `..` pattern are used.+--+-- @+--   data P = P { x :: Int }+--+--   foo (P{..}) = ()+-- @+--+-- The `..` pattern binds `x` but it is not used in the RHS so we issue+-- a warning.+warnUnusedRecordWildcard :: [Name] -> FreeVars -> RnM ()+warnUnusedRecordWildcard ns used_names = do+  let used = filter (`elemNameSet` used_names) ns+  traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used)+  warnIfFlag Opt_WarnUnusedRecordWildcards (null used)+    unusedRecordWildcardWarning+++ warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns   :: [Name] -> FreeVars -> RnM () warnUnusedLocalBinds   = check_unused Opt_WarnUnusedLocalBinds@@ -296,6 +348,20 @@          nest 2 $ pprNonVarNameSpace (occNameSpace occ)                         <+> quotes (ppr occ)] +unusedRecordWildcardWarning :: SDoc+unusedRecordWildcardWarning =+  wildcardDoc $ text "No variables bound in the record wildcard match are used"++redundantWildcardWarning :: SDoc+redundantWildcardWarning =+  wildcardDoc $ text "Record wildcard does not bind any new variables"++wildcardDoc :: SDoc -> SDoc+wildcardDoc herald =+  herald+    $$ nest 2 (text "Possible fix" <> colon <+> text "omit the"+                                            <+> quotes (text ".."))+ addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM () addNameClashErrRn rdr_name gres   | all isLocalGRE gres && not (all isRecFldGRE gres)@@ -319,7 +385,7 @@     --   It could refer to either ‘T15487a.null’,     --                            imported from ‘Prelude’ at T15487.hs:1:8-13     --                     or ...-    -- See Trac #15487+    -- See #15487     pp_gre_name gre@(GRE { gre_name = name, gre_par = parent                          , gre_lcl = lcl, gre_imp = iss })       | FldParent { par_lbl = Just lbl } <- parent@@ -392,6 +458,7 @@ --          Merge TcType.UserTypeContext in to it. data HsDocContext   = TypeSigCtx SDoc+  | StandaloneKindSigCtx SDoc   | PatCtx   | SpecInstSigCtx   | DefaultDeclCtx@@ -421,6 +488,7 @@ pprHsDocContext :: HsDocContext -> SDoc pprHsDocContext (GenericCtx doc)      = doc pprHsDocContext (TypeSigCtx doc)      = text "the type signature for" <+> doc+pprHsDocContext (StandaloneKindSigCtx doc) = text "the standalone kind signature for" <+> doc pprHsDocContext PatCtx                = text "a pattern type-signature" pprHsDocContext SpecInstSigCtx        = text "a SPECIALISE instance pragma" pprHsDocContext DefaultDeclCtx        = text "a `default' declaration"
compiler/simplCore/CSE.hs view
@@ -8,14 +8,14 @@  module CSE (cseProgram, cseOneExpr) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import CoreSubst import Var              ( Var ) import VarEnv           ( elemInScopeSet, mkInScopeSet )-import Id               ( Id, idType, isDeadBinder+import Id               ( Id, idType, isDeadBinder, idHasRules                         , idInlineActivation, setInlineActivation                         , zapIdOccInfo, zapIdUsageInfo, idInlinePragma                         , isJoinId, isJoinId_maybe )@@ -84,7 +84,7 @@      - First, the original RHS might have been (g z) which has CSE'd       with an enclosing (let y = g z in ...).  This is super-important.-      See Trac #5996:+      See #5996:          x1 = C a b          x2 = C x1 b          y1 = C a b@@ -104,7 +104,7 @@    Note that we use EXTEND even for a trivial expression, provided it   is not a variable or literal. In particular this /includes/ type-  applications. This can be important (Trac #13156); e.g.+  applications. This can be important (#13156); e.g.      case f @ Int of { r1 ->      case f @ Int of { r2 -> ...   Here we want to common-up the two uses of (f @ Int) so we can@@ -392,9 +392,15 @@  delayInlining :: TopLevelFlag -> Id -> Id -- Add a NOINLINE[2] if the Id doesn't have an INLNE pragma already+-- See Note [Delay inlining after CSE] delayInlining top_lvl bndr   | isTopLevel top_lvl   , isAlwaysActive (idInlineActivation bndr)+  , idHasRules bndr  -- Only if the Id has some RULES,+                     -- which might otherwise get lost+       -- These rules are probably auto-generated specialisations,+       -- since Ids with manual rules usually have manually-inserted+       -- delayed inlining anyway   = bndr `setInlineActivation` activeAfterInitial   | otherwise   = bndr@@ -419,7 +425,7 @@        -- Putting the Id into the cs_map makes it possible that        -- it'll become shared more than it is now, which would        -- invalidate (the usage part of) its demand info.-       --    This caused Trac #100218.+       --    This caused #100218.        -- Easiest thing is to zap the usage info; subsequently        -- performing late demand-analysis will restore it.  Don't zap        -- the strictness info; it's not necessary to do so, and losing@@ -475,11 +481,11 @@   - Use SUBSTITUTE, by extending the substitution with  y :-> x   - but leave the original binding for y undisturbed -This is done by cse_bind.  I got it wrong the first time (Trac #13367).+This is done by cse_bind.  I got it wrong the first time (#13367).  Note [Delay inlining after CSE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose (Trac #15445) we have+Suppose (#15445) we have    f,g :: Num a => a -> a    f x = ...f (x-1).....    g y = ...g (y-1) ....@@ -494,13 +500,49 @@ Now there is terrible danger that, in an importing module, we'll inline 'g' before we have a chance to run its specialisation! -Solution: during CSE, when adding a top-level-  g = f-binding after a "hit" in the CSE cache, add a NOINLINE[2] activation-to it, to ensure it's not inlined right away.+Solution: during CSE, afer a "hit" in the CSE cache+  * when adding a binding+        g = f+  * for a top-level function g+  * and g has specialisation RULES+add a NOINLINE[2] activation to it, to ensure it's not inlined+right away. -Why top level only?  Because for nested bindings we are already past-phase 2 and will never return there.+Notes:+* Why top level only?  Because for nested bindings we are already past+  phase 2 and will never return there.++* Why "only if g has RULES"?  Because there is no point in+  doing this if there are no RULES; and other things being+  equal it delays optimisation to delay inlining (#17409)+++---- Historical note ---++This patch is simpler and more direct than an earlier+version:++  commit 2110738b280543698407924a16ac92b6d804dc36+  Author: Simon Peyton Jones <simonpj@microsoft.com>+  Date:   Mon Jul 30 13:43:56 2018 +0100++  Don't inline functions with RULES too early++We had to revert this patch because it made GHC itself slower.++Why? It delayed inlining of /all/ functions with RULES, and that was+very bad in TcFlatten.flatten_ty_con_app++* It delayed inlining of liftM+* That delayed the unravelling of the recursion in some dictionary+  bindings.+* That delayed some eta expansion, leaving+     flatten_ty_con_app = \x y. let <stuff> in \z. blah+* That allowed the float-out pass to put sguff between+  the \y and \z.+* And that permanently stopped eta expasion of the function,+  even once <stuff> was simplified.+ -}  tryForCSE :: CSEnv -> InExpr -> OutExpr
compiler/simplCore/CallArity.hs view
@@ -418,7 +418,7 @@ The analysis *could* make use of the fact that join points are always evaluated in the same context as the join-binding they are defined in and are always one-shot, and handle join points separately, as suggested in-https://ghc.haskell.org/trac/ghc/ticket/13479#comment:10.+https://gitlab.haskell.org/ghc/ghc/issues/13479#note_134870. This *might* be more efficient (for example, join points would not have to be considered interesting variables), but it would also add redundant code. So for now we do not do that.
compiler/simplCore/Exitify.hs view
@@ -245,7 +245,7 @@                                | otherwise           = (fvs',               acc)          -- We are going to abstract over these variables, so we must-        -- zap any IdInfo they have; see Trac #15005+        -- zap any IdInfo they have; see #15005         -- cf. SetLevels.abstractVars         zap v | isId v = setIdInfo v vanillaIdInfo               | otherwise = v
compiler/simplCore/FloatIn.hs view
@@ -17,12 +17,12 @@  module FloatIn ( floatInwards ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import CoreSyn-import MkCore+import MkCore hiding    ( wrapFloats ) import HscTypes         ( ModGuts(..) ) import CoreUtils import CoreFVs@@ -210,7 +210,7 @@ /in the original input program/.  e.g.    case x of { DEFAULT -> 1# } But, while this may be unusual it is not actually wrong, and it did-once happen (Trac #15696).+once happen (#15696).  Note [Do not destroy the let/app invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -307,7 +307,7 @@  fiExpr dflags to_drop lam@(_, AnnLam _ _)   | noFloatIntoLam bndrs       -- Dump it all here-     -- NB: Must line up with noFloatIntoRhs (AnnLam...); see Trac #7088+     -- NB: Must line up with noFloatIntoRhs (AnnLam...); see #7088   = wrapFloats to_drop (mkLams bndrs (fiExpr dflags [] body))    | otherwise           -- Float inside@@ -391,7 +391,7 @@ {- Note [Floating primops] ~~~~~~~~~~~~~~~~~~~~~~~~~~ We try to float-in a case expression over an unlifted type.  The-motivating example was Trac #5658: in particular, this change allows+motivating example was #5658: in particular, this change allows array indexing operations, which have a single DEFAULT alternative without any binders, to be floated inward. @@ -421,10 +421,10 @@   Solution: only float cases into the branches of other cases, and   not into the arguments of an application, or the RHS of a let. This   is somewhat conservative, but it's simple.  And it still hits the-  cases like Trac #5658.   This is implemented in sepBindsByJoinPoint;+  cases like #5658.   This is implemented in sepBindsByJoinPoint;   if is_case is False we dump all floating cases right here. -* Trac #14511 is another example of why we want to restrict float-in+* #14511 is another example of why we want to restrict float-in   of case-expressions.  Consider      case indexArray# a n of (# r #) -> writeArray# ma i (f r)   Now, floating that indexing operation into the (f r) thunk will@@ -613,7 +613,7 @@      (a) any non-one-shot value lambdas   or (b) all type lambdas   In both cases we'll float straight back out again-  NB: Must line up with fiExpr (AnnLam...); see Trac #7088+  NB: Must line up with fiExpr (AnnLam...); see #7088    (a) is important: we /must/ float into a one-shot lambda group   (which includes join points). This makes a big difference
compiler/simplCore/FloatOut.hs view
@@ -33,7 +33,7 @@  import Data.List        ( partition ) -#include "GhclibHsVersions.h"+#include "HsVersions.h"  {-         -----------------@@ -305,7 +305,7 @@     f = case x of I# y -> \xy. body because now f's arity might get worse, which is Not Good. (And if there's an SCC around the RHS it might not get better again.-See Trac #5342.)+See #5342.)  So, gruesomely, we split the floats into  * the outer FloatLets, which can join the Rec, and@@ -629,7 +629,7 @@  addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] addTopFloatPairs float_bag prs-  = foldrBag add prs float_bag+  = foldr add prs float_bag   where     add (NonRec b r) prs  = (b,r):prs     add (Rec prs1)   prs2 = prs1 ++ prs2@@ -673,7 +673,7 @@  install :: Bag FloatBind -> CoreExpr -> CoreExpr install defn_groups expr-  = foldrBag wrapFloat expr defn_groups+  = foldr wrapFloat expr defn_groups  partitionByLevel         :: Level                -- Partitioning level
compiler/simplCore/LiberateCase.hs view
@@ -7,7 +7,7 @@ {-# LANGUAGE CPP #-} module LiberateCase ( liberateCase ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude
compiler/simplCore/SAT.hs view
@@ -69,10 +69,10 @@ import UniqSet import Outputable -import Data.List+import Data.List (mapAccumL) import FastString -#include "GhclibHsVersions.h"+#include "HsVersions.h"  doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds
compiler/simplCore/SetLevels.hs view
@@ -60,7 +60,7 @@         incMinorLvl, ltMajLvl, ltLvl, isTopLvl     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -89,7 +89,7 @@ import Name             ( getOccName, mkSystemVarName ) import OccName          ( occNameString ) import Type             ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType-                        , isUnliftedType, closeOverKindsDSet )+                        , mightBeUnliftedType, closeOverKindsDSet ) import BasicTypes       ( Arity, RecFlag(..), isRec ) import DataCon          ( dataConOrigResTy ) import TysWiredIn@@ -536,6 +536,32 @@   * We only do this with a single-alternative case ++Note [Setting levels when floating single-alternative cases]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Handling level-setting when floating a single-alternative case binding+is a bit subtle, as evidenced by #16978.  In particular, we must keep+in mind that we are merely moving the case and its binders, not the+body. For example, suppose 'a' is known to be evaluated and we have++  \z -> case a of+          (x,_) -> <body involving x and z>++After floating we may have:++  case a of+    (x,_) -> \z -> <body involving x and z>+      {- some expression involving x and z -}++When analysing <body involving...> we want to use the /ambient/ level,+and /not/ the desitnation level of the 'case a of (x,-) ->' binding.++#16978 was caused by us setting the context level to the destination+level of `x` when analysing <body>. This led us to conclude that we+needed to quantify over some of its free variables (e.g. z), resulting+in shadowing and very confusing Core Lint failures.++ Note [Check the output scrutinee for exprIsHNF] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this:@@ -549,7 +575,7 @@ the *input* one 'y'.  The latter *is* in HNF here (because y is evaluated), but the former is not -- and indeed we can't float the inner case out, at least not unless x is also evaluated at its binding-site.  See Trac #5453.+site.  See #5453.  That's why we apply exprIsHNF to scrut' and not to scrut. @@ -756,7 +782,7 @@ Note [Floating join point bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Mostly we only float a join point if it can /stay/ a join point.  But-there is one exception: if it can go to the top level (Trac #13286).+there is one exception: if it can go to the top level (#13286). Consider   f x = joinrec j y n = <...j y' n'...>         in jump j x 0@@ -809,7 +835,7 @@    case (case y of I# r -> r) of r -> blah  Being able to float unboxed expressions is sometimes important; see-Trac #12603.  I'm not sure how /often/ it is important, but it's+#12603.  I'm not sure how /often/ it is important, but it's not hard to achieve.  We only do it for a fixed collection of types for which we have a@@ -913,7 +939,7 @@     errors, e.g. via a case with empty alternatives:  (case x of {})     Lint complains unless the scrutinee of such a case is clearly bottom. -    This was reported in Trac #11290.   But since the whole bottoming-float+    This was reported in #11290.   But since the whole bottoming-float     thing is based on the cheap-and-cheerful exprIsBottom, I'm not sure     that it'll nail all such cases. @@ -977,18 +1003,17 @@     go (Tick t e) n  = not (tickishIsCode t) && go e n     go (Cast e _)  n = go e n     go (App e arg) n-       | Type {}     <- arg = go e n-       | Coercion {} <- arg = go e n-       | n==0               = False-       | is_triv arg        = go e (n-1)-       | otherwise          = False-    go _ _                  = False+       -- See Note [Floating applications to coercions]+       | Type {} <- arg = go e n+       | n==0           = False+       | is_triv arg    = go e (n-1)+       | otherwise      = False+    go _ _              = False      is_triv (Lit {})              = True        -- Treat all literals as trivial     is_triv (Var {})              = True        -- (ie not worth floating)     is_triv (Cast e _)            = is_triv e-    is_triv (App e (Type {}))     = is_triv e-    is_triv (App e (Coercion {})) = is_triv e+    is_triv (App e (Type {}))     = is_triv e   -- See Note [Floating applications to coercions]     is_triv (Tick t e)            = not (tickishIsCode t) && is_triv e     is_triv _                     = False @@ -1002,6 +1027,14 @@ Ditto literal strings (LitString), which we'd like to float to top level, which is now possible. +Note [Floating applications to coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don’t float out variables applied only to type arguments, since the+extra binding would be pointless: type arguments are completely erased.+But *coercion* arguments aren’t (see Note [Coercion tokens] in+CoreToStg.hs and Note [Count coercion arguments in boring contexts] in+CoreUnfold.hs), so we still want to float out variables applied only to+coercion arguments.  Note [Escaping a value lambda] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1099,8 +1132,8 @@   |  floatTopLvlOnly env && not (isTopLvl dest_lvl)          -- Only floating to the top level is allowed.   || not (profitableFloat env dest_lvl)-  || (isTopLvl dest_lvl && any (isUnliftedType . idType) bndrs)-       -- This isUnliftedType stuff is the same test as in the non-rec case+  || (isTopLvl dest_lvl && any (mightBeUnliftedType . idType) bndrs)+       -- This mightBeUnliftedType stuff is the same test as in the non-rec case        -- You might wonder whether we can have a recursive binding for        -- an unlifted value -- but we can if it's a /join binding/ (#16978)        -- (Ultimately I think we should not use SetLevels to@@ -1276,7 +1309,7 @@   * any value lambdas in the original function, and   * this is not a bottoming function (the is_bot argument) Use lvlExpr otherwise.  A little subtle, and I got it wrong at least twice-(e.g. Trac #13369).+(e.g. #13369). -}  {-@@ -1407,7 +1440,7 @@ is just tOP_LEVEL; but occasionally a coercion variable (which is an Id) mentioned in type prevents this. -Example Trac #14270 comment:15.+Example #14270 comment:15. -}  @@ -1669,11 +1702,16 @@       | otherwise       = mkSysLocalOrCoVar (mkFastString "lvl") uniq rhs_ty +-- | Clone the binders bound by a single-alternative case. cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var]) cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })                new_lvl vs   = do { us <- getUniqueSupplyM        ; let (subst', vs') = cloneBndrs subst us vs+             -- N.B. We are not moving the body of the case, merely its case+             -- binders.  Consequently we should *not* set le_ctxt_lvl and+             -- le_join_ceil.  See Note [Setting levels when floating+             -- single-alternative cases].              env' = env { le_lvl_env   = addLvls new_lvl lvl_env vs'                         , le_subst     = subst'                         , le_env       = foldl' add_id id_env (vs `zip` vs') }
compiler/simplCore/SimplCore.hs view
@@ -8,7 +8,7 @@  module SimplCore ( core2core, simplifyExpr ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -36,7 +36,7 @@ import FloatOut         ( floatOutwards ) import FamInstEnv import Id-import ErrUtils         ( withTiming )+import ErrUtils         ( withTiming, withTimingD ) import BasicTypes       ( CompilerPhase(..), isDefaultInlinePragma, defaultInlinePragma ) import VarSet import VarEnv@@ -72,13 +72,13 @@                                 , mg_loc     = loc                                 , mg_deps    = deps                                 , mg_rdr_env = rdr_env })-  = do { us <- mkSplitUniqSupply 's'-       -- make sure all plugins are loaded+  = do { -- make sure all plugins are loaded         ; let builtin_passes = getCoreToDo dflags              orph_mods = mkModuleSet (mod : dep_orphs deps)+             uniq_mask = 's'        ;-       ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod+       ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod                                     orph_mods print_unqual loc $                            do { hsc_env' <- getHscEnv                               ; dflags' <- liftIO $ initializePlugins hsc_env'@@ -339,7 +339,7 @@         -- really really one-shot thunks. Only needed if the demand analyser         -- has run at all. See Note [Final Demand Analyser run] in DmdAnal         -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution-        -- can become /exponentially/ more expensive. See Trac #11731, #12996.+        -- can become /exponentially/ more expensive. See #11731, #12996.         runWhen (strictness || late_dmd_anal) CoreDoStrictness,          maybe_rule_check (Phase 0)@@ -410,10 +410,9 @@   where     do_pass guts CoreDoNothing = return guts     do_pass guts (CoreDoPasses ps) = runCorePasses ps guts-    do_pass guts pass-       = withTiming getDynFlags-                    (ppr pass <+> brackets (ppr mod))-                    (const ()) $ do+    do_pass guts pass = do+       withTimingD (ppr pass <+> brackets (ppr mod))+                   (const ()) $ do             { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts             ; endPass pass (mg_binds guts') (mg_rules guts')             ; return guts' }@@ -462,11 +461,7 @@ doCorePass CoreDoNothing                = return doCorePass (CoreDoPasses passes)        = runCorePasses passes -#if defined(GHCI) doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass-#else-doCorePass pass@CoreDoPluginPass {}  = pprPanic "doCorePass" (ppr pass)-#endif  doCorePass pass@CoreDesugar          = pprPanic "doCorePass" (ppr pass) doCorePass pass@CoreDesugarOpt       = pprPanic "doCorePass" (ppr pass)@@ -488,9 +483,8 @@  ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts ruleCheckPass current_phase pat guts =-    withTiming getDynFlags-               (text "RuleCheck"<+>brackets (ppr $ mg_module guts))-               (const ()) $ do+    withTimingD (text "RuleCheck"<+>brackets (ppr $ mg_module guts))+                (const ()) $ do     { rb <- getRuleBase     ; dflags <- getDynFlags     ; vis_orphs <- getVisibleOrphanMods@@ -568,7 +562,7 @@ -- -- Also used by Template Haskell simplifyExpr dflags expr-  = withTiming (pure dflags) (text "Simplify [expr]") (const ()) $+  = withTiming dflags (text "Simplify [expr]") (const ()) $     do  {         ; us <-  mkSplitUniqSupply 's'
compiler/simplCore/SimplEnv.hs view
@@ -43,7 +43,7 @@         wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -69,7 +69,7 @@ import Util import UniqFM                   ( pprUniqFM ) -import Data.List+import Data.List (mapAccumL)  {- ************************************************************************@@ -667,7 +667,9 @@          -- Get the most up-to-date thing from the in-scope set         -- Even though it isn't in the substitution, it may be in-        -- the in-scope set with better IdInfo+        -- the in-scope set with better IdInfo.+        --+        -- See also Note [In-scope set as a substitution] in Simplify.  refineFromInScope :: InScopeSet -> Var -> Var refineFromInScope in_scope v
compiler/simplCore/SimplMonad.hs view
@@ -4,6 +4,7 @@ \section[SimplMonad]{The simplifier Monad} -} +{-# LANGUAGE DeriveFunctor #-} module SimplMonad (         -- The monad         SimplM,@@ -21,7 +22,7 @@  import GhcPrelude -import Var              ( Var, isTyVar, mkLocalVar )+import Var              ( Var, isId, mkLocalVar ) import Name             ( mkSystemVarName ) import Id               ( Id, mkSysLocalOrCoVar ) import IdInfo           ( IdDetails(..), vanillaIdInfo, setArityInfo )@@ -35,9 +36,10 @@ import FastString import MonadUtils import ErrUtils as Err-import Panic (throwGhcExceptionIO, GhcException (..))+import Util                ( count )+import Panic               (throwGhcExceptionIO, GhcException (..)) import BasicTypes          ( IntWithInf, treatZeroAsInf, mkIntWithInf )-import Control.Monad       ( liftM, ap )+import Control.Monad       ( ap )  {- ************************************************************************@@ -57,6 +59,7 @@                 -> SimplCount                 -> IO (result, UniqSupply, SimplCount)}   -- we only need IO here for dump output+    deriving (Functor)  data SimplTopEnv   = STE { st_flags     :: DynFlags@@ -97,16 +100,13 @@         -- MAGIC NUMBER, multiplies the simplTickFactor         -- We can afford to be generous; this is really         -- just checking for loops, and shouldn't usually fire-        -- A figure of 20 was too small: see Trac #5539.+        -- A figure of 20 was too small: see #5539.  {-# INLINE thenSmpl #-} {-# INLINE thenSmpl_ #-} {-# INLINE returnSmpl #-}  -instance Functor SimplM where-    fmap = liftM- instance Applicative SimplM where     pure  = returnSmpl     (<*>) = ap@@ -187,7 +187,8 @@   = do { uniq <- getUniqueM        ; let name       = mkSystemVarName uniq (fsLit "$j")              join_id_ty = mkLamTypes bndrs body_ty  -- Note [Funky mkLamTypes]-             arity      = length (filter (not . isTyVar) bndrs)+             arity      = count isId bndrs+             -- arity: See Note [Invariants on join points] invariant 2b, in CoreSyn              join_arity = length bndrs              details    = JoinId join_arity              id_info    = vanillaIdInfo `setArityInfo` arity
compiler/simplCore/SimplUtils.hs view
@@ -36,7 +36,7 @@         isExitJoinId     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -46,6 +46,7 @@ import CoreSyn import qualified CoreSubst import PprCore+import TyCoPpr          ( pprParendType ) import CoreFVs import CoreUtils import CoreArity@@ -412,8 +413,8 @@ contHoleType (StrictArg { sc_fun = ai })      = funArgTy (ai_type ai) contHoleType (ApplyToTy  { sc_hole_ty = ty }) = ty  -- See Note [The hole type in ApplyToTy] contHoleType (ApplyToVal { sc_arg = e, sc_env = se, sc_dup = dup, sc_cont = k })-  = mkFunTy (perhapsSubstTy dup se (exprType e))-            (contHoleType k)+  = mkVisFunTy (perhapsSubstTy dup se (exprType e))+               (contHoleType k) contHoleType (Select { sc_dup = d, sc_bndr =  b, sc_env = se })   = perhapsSubstTy d se (idType b) @@ -542,7 +543,7 @@  Note [Do not expose strictness if sm_inline=False] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Trac #15163 showed a case in which we had+#15163 showed a case in which we had    {-# INLINE [1] zip #-}   zip = undefined@@ -708,7 +709,7 @@ exprIsHNF.  Before 2009 we said it was interesting if the argument had *any* structure-at all; i.e. (hasSomeUnfolding v).  But does too much inlining; see Trac #3016.+at all; i.e. (hasSomeUnfolding v).  But does too much inlining; see #3016.  But we don't regard (f x y) as interesting, unless f is unsaturated. If it's saturated and f hasn't inlined, then it's probably not going@@ -822,12 +823,12 @@ of other RULES.  Doing anything to the LHS is plain confusing, because it means that what the-rule matches is not what the user wrote. c.f. Trac #10595, and #10528.+rule matches is not what the user wrote. c.f. #10595, and #10528. Moreover, inlining (or applying rules) on rule LHSs risks introducing-Ticks into the LHS, which makes matching trickier. Trac #10665, #10745.+Ticks into the LHS, which makes matching trickier. #10665, #10745.  Doing this to either side confounds tools like HERMIT, which seek to reason-about and apply the RULES as originally written. See Trac #10829.+about and apply the RULES as originally written. See #10829.  Note [No eta expansion in stable unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -844,7 +845,7 @@   --    = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co  because not specialisation of the overloading doesn't work properly-(see Note [Specialisation shape] in Specialise), Trac #9509.+(see Note [Specialisation shape] in Specialise), #9509.  So we disable eta-expansion in stable unfoldings. @@ -1109,7 +1110,7 @@ at each of fInt's call sites.  The INLINE pragma will only inline when the application is saturated for exactly this reason; and we don't want PreInlineUnconditionally to second-guess it.  A live example is-Trac #3736.+#3736.     c.f. Note [Stable unfoldings and postInlineUnconditionally]  NB: if the pragma is INLINEABLE, then we don't want to behave in@@ -1508,7 +1509,7 @@                 -> SimplM (Arity, Bool, OutExpr) -- See Note [Eta-expanding at let bindings] -- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then---   (a) rhs' has manifest arity+--   (a) rhs' has manifest arity n --   (b) if is_bot is True then rhs' applied to n args is guaranteed bottom tryEtaExpandRhs mode bndr rhs   | Just join_arity <- isJoinId_maybe bndr@@ -1516,7 +1517,8 @@        ; return (count isId join_bndrs, exprIsBottom join_body, rhs) }          -- Note [Do not eta-expand join points]          -- But do return the correct arity and bottom-ness, because-         -- these are used to set the bndr's IdInfo (Trac #15517)+         -- these are used to set the bndr's IdInfo (#15517)+         -- Note [Invariants on join points] invariant 2b, in CoreSyn    | otherwise   = do { (new_arity, is_bot, new_rhs) <- try_expand@@ -1614,7 +1616,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to have old_arity = manifestArity rhs, which meant that we would eta-expand even PAPs.  But this gives no particular advantage,-and can lead to a massive blow-up in code size, exhibited by Trac #9020.+and can lead to a massive blow-up in code size, exhibited by #9020. Suppose we have a PAP     foo :: IO ()     foo = returnIO ()@@ -1731,7 +1733,7 @@          poly_t = /\ a b -> (e1, e2)          poly_x = /\ a   -> fst (poly_t a *b*) -  * We must do closeOverKinds.  Example (Trac #10934):+  * We must do closeOverKinds.  Example (#10934):        f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ...     Here we want to float 't', but we must remember to abstract over     'k' as well, even though it is not explicitly mentioned in the RHS,@@ -2204,8 +2206,10 @@            ; return (ex_tvs ++ arg_ids) }     mk_new_bndrs _ _ = return [] -    re_sort :: [CoreAlt] -> [CoreAlt]  -- Re-sort the alternatives to-    re_sort alts = sortBy cmpAlt alts  -- preserve the #case_invariants#+    re_sort :: [CoreAlt] -> [CoreAlt]+    -- Sort the alternatives to re-establish+    -- CoreSyn Note [Case expression invariants]+    re_sort alts = sortBy cmpAlt alts      add_default :: [CoreAlt] -> [CoreAlt]     -- See Note [Literal cases]
compiler/simplCore/Simplify.hs view
@@ -8,7 +8,7 @@  module Simplify ( simplTopBinds, simplExpr, simplRules ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -22,7 +22,8 @@ import Literal          ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326 import Id import MkId             ( seqId )-import MkCore           ( mkImpossibleExpr, castBottomExpr )+import MkCore           ( FloatBind, mkImpossibleExpr, castBottomExpr )+import qualified MkCore as MkCore import IdInfo import Name             ( mkSystemVarName, isExternalName, getOccFS ) import Coercion hiding  ( substCo, substCoVar )@@ -40,7 +41,7 @@ import CoreOpt          ( pushCoTyArg, pushCoValArg                         , joinPointBinding_maybe, joinPointBindings_maybe ) import Rules            ( mkRuleInfo, lookupRule, getRules )-import Demand           ( mkClosedStrictSig, topDmd, exnRes )+import Demand           ( mkClosedStrictSig, topDmd, botRes ) import BasicTypes       ( TopLevelFlag(..), isNotTopLevel, isTopLevel,                           RecFlag(..), Arity ) import MonadUtils       ( mapAccumLM, liftIO )@@ -117,6 +118,40 @@ we should eta expand wherever we find a (value) lambda?  Then the eta expansion at a let RHS can concentrate solely on the PAP case. +Note [In-scope set as a substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As per Note [Lookups in in-scope set], an in-scope set can act as+a substitution. Specifically, it acts as a substitution from variable to+variables /with the same unique/.++Why do we need this? Well, during the course of the simplifier, we may want to+adjust inessential properties of a variable. For instance, when performing a+beta-reduction, we change++    (\x. e) u ==> let x = u in e++We typically want to add an unfolding to `x` so that it inlines to (the+simplification of) `u`.++We do that by adding the unfolding to the binder `x`, which is added to the+in-scope set. When simplifying occurrences of `x` (every occurrence!), they are+replaced by their “updated” version from the in-scope set, hence inherit the+unfolding. This happens in `SimplEnv.substId`.++Another example. Consider++   case x of y { Node a b -> ...y...+               ; Leaf v   -> ...y... }++In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we+want y's unfolding to be (Leaf v). We achieve this by adding the appropriate+unfolding to y, and re-adding it to the in-scope set. See the calls to+`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere.++It's quite convenient. This way we don't need to manipulate the substitution all+the time: every update to a binder is automatically reflected to its bound+occurrences.+ ************************************************************************ *                                                                      * \subsection{Bindings}@@ -658,6 +693,7 @@                                            final_rhs (idType new_bndr) old_unf        ; let final_bndr = addLetBndrInfo new_bndr new_arity is_bot new_unfolding+        -- See Note [In-scope set as a substitution]        ; if postInlineUnconditionally env top_lvl final_bndr occ_info final_rhs @@ -695,7 +731,7 @@      -- Bottoming bindings: see Note [Bottoming bindings]     info4 | is_bot    = info3 `setStrictnessInfo`-                        mkClosedStrictSig (replicate new_arity topDmd) exnRes+                        mkClosedStrictSig (replicate new_arity topDmd) botRes           | otherwise = info3       -- Zap call arity info. We have used it by now (via@@ -745,7 +781,7 @@ does a simple bottoming-expression analysis.  So all we need to do is propagate that info to the binder's IdInfo. -This showed up in Trac #12150; see comment:16.+This showed up in #12150; see comment:16.  Note [Setting the demand info] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1217,7 +1253,7 @@ {- Note [Optimising reflexivity] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's important (for compiler performance) to get rid of reflexivity as soon-as it appears.  See Trac #11735, #14737, and #15019.+as it appears.  See #11735, #14737, and #15019.  In particular, we want to behave well on @@ -1231,7 +1267,7 @@    build up NthCo stacks.  Silly to do that if co is reflexive.  However, we don't want to call isReflexiveCo too much, because it uses-type equality which is expensive on big types (Trac #14737 comment:7).+type equality which is expensive on big types (#14737 comment:7).  A good compromise (determined experimentally) seems to be to call isReflexiveCo@@ -1239,7 +1275,7 @@  * at the end  In investigating this I saw missed opportunities for on-the-fly-coercion shrinkage. See Trac #15090.+coercion shrinkage. See #15090. -}  @@ -1268,7 +1304,11 @@          addCoerce co cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })           | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty-          , Pair hole_ty _ <- coercionKind co+            -- N.B. As mentioned in Note [The hole type in ApplyToTy] this is+            -- only needed by `sc_hole_ty` which is often not forced.+            -- Consequently it is worthwhile using a lazy pattern match here to+            -- avoid unnecessary coercionKind evaluations.+          , ~(Pair hole_ty _) <- coercionKind co           = {-#SCC "addCoerce-pushCoTyArg" #-}             do { tail' <- addCoerceM m_co' tail                ; return (cont { sc_arg_ty  = arg_ty'@@ -1295,7 +1335,7 @@                     -- 'co' with the InExpr 'arg', so we simplify                     -- to make it all consistent.  It's a bit messy.                     -- But it isn't a common case.-                    -- Example of use: Trac #995+                    -- Example of use: #995                ; return (ApplyToVal { sc_arg  = mkCast arg' co1                                     , sc_env  = arg_se'                                     , sc_dup  = dup'@@ -1527,7 +1567,7 @@ simplifying the right-hand side, so we remember whether or not it is a join point, and what 'cont' is, in a value of type MaybeJoinCont -Trac #13900 wsa caused by forgetting to push 'cont' into the RHS+#13900 wsa caused by forgetting to push 'cont' into the RHS of a SpecConstr-generated RULE for a join point. -} @@ -2050,11 +2090,16 @@     no_cast_scrut = drop_casts scrut     scrut_ty  = exprType no_cast_scrut     seq_id_ty = idType seqId+    res1_ty   = piResultTy seq_id_ty rhs_rep+    res2_ty   = piResultTy res1_ty   scrut_ty     rhs_ty    = substTy in_env (exprType rhs)-    out_args  = [ TyArg { as_arg_ty  = scrut_ty+    rhs_rep   = getRuntimeRep rhs_ty+    out_args  = [ TyArg { as_arg_ty  = rhs_rep                         , as_hole_ty = seq_id_ty }+                , TyArg { as_arg_ty  = scrut_ty+                        , as_hole_ty = res1_ty }                 , TyArg { as_arg_ty  = rhs_ty-                       , as_hole_ty  = piResultTy seq_id_ty scrut_ty }+                        , as_hole_ty = res2_ty }                 , ValArg no_cast_scrut]     rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs                            , sc_env = in_env, sc_cont = cont }@@ -2272,7 +2317,7 @@ This is a Good Thing, because 'r' might be dead (if the body just calls error), or might be used just once (in which case it can be inlined); or we might be able to float the let-binding up or down.-E.g. Trac #15631 has an example.+E.g. #15631 has an example.  Note that this can change the error behaviour.  For example, we might transform@@ -2283,7 +2328,7 @@  Nevertheless, the paper "A semantics for imprecise exceptions" allows this transformation. If you want to fix the evaluation order, use-'pseq'.  See Trac #8900 for an example where the loss of this+'pseq'.  See #8900 for an example where the loss of this transformation bit us in practice.  See also Note [Empty case alternatives] in CoreSyn.@@ -2301,7 +2346,7 @@     scrut_is_demanded_var _          = False    This only fired if the scrutinee was a /variable/, which seems-  an unnecessary restriction. So in Trac #15631 I relaxed it to allow+  an unnecessary restriction. So in #15631 I relaxed it to allow   arbitrary scrutinees.  Less code, less to explain -- but the change   had 0.00% effect on nofib. @@ -2316,7 +2361,7 @@     case_bndr_evald_next (Case e _ _ _)  = case_bndr_evald_next e     case_bndr_evald_next _               = False -  This patch was part of fixing Trac #7542. See also+  This patch was part of fixing #7542. See also   Note [Eta reduction of an eval'd function] in CoreUtils.)  @@ -2358,6 +2403,26 @@ wrong to drop even unnecessary evaluations, and in practice they may be a result of 'seq' so we *definitely* don't want to drop those. I don't really know how to improve this situation.+++Note [FloatBinds from constructor wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have FloatBinds coming from the constructor wrapper+(as in Note [exprIsConApp_maybe on data constructors with wrappers]),+ew cannot float past them. We'd need to float the FloatBind+together with the simplify floats, unfortunately the+simplifier doesn't have case-floats. The simplest thing we can+do is to wrap all the floats here. The next iteration of the+simplifier will take care of all these cases and lets.++Given data T = MkT !Bool, this allows us to simplify+case $WMkT b of { MkT x -> f x }+to+case b of { b' -> f b' }.++We could try and be more clever (like maybe wfloats only contain+let binders, so we could float them). But the need for the+extra complication is not clear. -}  ---------------------------------------------------------@@ -2367,7 +2432,7 @@    :: SimplEnv    -> OutExpr          -- Scrutinee    -> InId             -- Case binder-   -> [InAlt]          -- Alternatives (inceasing order)+   -> [InAlt]          -- Alternatives (increasing order)    -> SimplCont    -> SimplM (SimplFloats, OutExpr) @@ -2382,25 +2447,37 @@   = do  { tick (KnownBranch case_bndr)         ; case findAlt (LitAlt lit) alts of             Nothing           -> missingAlt env case_bndr alts cont-            Just (_, bs, rhs) -> simple_rhs bs rhs }+            Just (_, bs, rhs) -> simple_rhs env [] scrut bs rhs } -  | Just (con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut+  | Just (in_scope', wfloats, con, ty_args, other_args)+      <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut         -- Works when the scrutinee is a variable with a known unfolding         -- as well as when it's an explicit constructor application+  , let env0 = setInScopeSet env in_scope'   = do  { tick (KnownBranch case_bndr)         ; case findAlt (DataAlt con) alts of-            Nothing  -> missingAlt env case_bndr alts cont-            Just (DEFAULT, bs, rhs) -> simple_rhs bs rhs-            Just (_, bs, rhs)       -> knownCon env scrut con ty_args other_args+            Nothing  -> missingAlt env0 case_bndr alts cont+            Just (DEFAULT, bs, rhs) -> let con_app = Var (dataConWorkId con)+                                                 `mkTyApps` ty_args+                                                 `mkApps`   other_args+                                       in simple_rhs env0 wfloats con_app bs rhs+            Just (_, bs, rhs)       -> knownCon env0 scrut wfloats con ty_args other_args                                                 case_bndr bs rhs cont         }   where-    simple_rhs bs rhs = ASSERT( null bs )-                        do { (floats1, env') <- simplNonRecX env case_bndr scrut-                               -- scrut is a constructor application,-                               -- hence satisfies let/app invariant-                           ; (floats2, expr') <- simplExprF env' rhs cont-                           ; return (floats1 `addFloats` floats2, expr') }+    simple_rhs env wfloats scrut' bs rhs =+      ASSERT( null bs )+      do { (floats1, env') <- simplNonRecX env case_bndr scrut'+             -- scrut is a constructor application,+             -- hence satisfies let/app invariant+         ; (floats2, expr') <- simplExprF env' rhs cont+         ; case wfloats of+             [] -> return (floats1 `addFloats` floats2, expr')+             _ -> return+               -- See Note [FloatBinds from constructor wrappers]+                   ( emptyFloats env,+                     MkCore.wrapFloats wfloats $+                     wrapFloats (floats1 `addFloats` floats2) expr' )}   --------------------------------------------------@@ -2533,7 +2610,7 @@ so that 'rhs' can take advantage of the form of x'.  Notice that Note [Case of cast] (in OccurAnal) may then apply to the result. -We'd also like to eliminate empty types (Trac #13468). So if+We'd also like to eliminate empty types (#13468). So if      data Void     type instance F Bool = Void@@ -2669,7 +2746,7 @@  In addition to handling data constructor fields with !s, addEvals also records the fact that the result of seq# is always in WHNF.-See Note [seq# magic] in PrelRules.  Example (Trac #15226):+See Note [seq# magic] in PrelRules.  Example (#15226):    case seq# v s of     (# s', v' #) -> E@@ -2678,7 +2755,7 @@  Open problem: we don't record that v itself is in WHNF (and we can't do it here).  The right thing is to do some kind of binder-swap;-see Trac #15226 for discussion.+see #15226 for discussion. -}  addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id]@@ -2770,7 +2847,7 @@ reallyUnsafePtrEq#, which it is.  But we still want that to be true if we propagate binders to occurrences. -This showed up in Trac #13027.+This showed up in #13027.  Note [Add unfolding for scrutinee] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2828,17 +2905,24 @@ -}  knownCon :: SimplEnv-         -> OutExpr                             -- The scrutinee-         -> DataCon -> [OutType] -> [OutExpr]   -- The scrutinee (in pieces)-         -> InId -> [InBndr] -> InExpr          -- The alternative+         -> OutExpr                                           -- The scrutinee+         -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr]  -- The scrutinee (in pieces)+         -> InId -> [InBndr] -> InExpr                        -- The alternative          -> SimplCont          -> SimplM (SimplFloats, OutExpr) -knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont+knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont   = do  { (floats1, env1)  <- bind_args env bs dc_args         ; (floats2, env2) <- bind_case_bndr env1         ; (floats3, expr') <- simplExprF env2 rhs cont-        ; return (floats1 `addFloats` floats2 `addFloats` floats3, expr') }+        ; case dc_floats of+            [] ->+              return (floats1 `addFloats` floats2 `addFloats` floats3, expr')+            _ ->+              return ( emptyFloats env+               -- See Note [FloatBinds from constructor wrappers]+                     , MkCore.wrapFloats dc_floats $+                       wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') }   where     zap_occ = zapBndrOccInfo (isDeadBinder bndr)    -- bndr is an InId @@ -2939,7 +3023,7 @@        of alts then we can just duplicate those alts because the A and C cases will disappear immediately.  This is more direct than creating-join points and inlining them away.  See Trac #4930.+join points and inlining them away.  See #4930. -}  --------------------@@ -3172,7 +3256,7 @@ This is just what we want because the rn produces a box that the case rn cancels with. -See Trac #4957 a fuller example.+See #4957 a fuller example.  Note [Case binders and join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -3270,7 +3354,7 @@ Now if the thing in the hole is a case expression (which is when we'll call mkDupableCont), we'll push the function call into the branches, which is what we want.  Now RULES for f may fire, and-call-pattern specialisation.  Here's an example from Trac #3116+call-pattern specialisation.  Here's an example from #3116      go (n+1) (case l of                  1  -> bs'                  _  -> Chunk p fpc (o+1) (l-1) bs')@@ -3453,7 +3537,7 @@                         -- has got small. This happens, notably in the inlinings                         -- for dfuns for single-method classes; see                         -- Note [Single-method classes] in TcInstDcls.-                        -- A test case is Trac #4138+                        -- A test case is #4138                         -- But retain a previous boring_ok of True; e.g. see                         -- the way it is set in calcUnfoldingGuidanceWithArity                         in return (mkCoreUnfolding src is_top_lvl expr' guide')
compiler/simplStg/SimplStg.hs view
@@ -11,7 +11,7 @@  module SimplStg ( stg2stg ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -32,15 +32,17 @@ import Control.Monad.IO.Class import Control.Monad.Trans.State.Strict -newtype StgM a = StgM { _unStgM :: StateT UniqSupply IO a }+newtype StgM a = StgM { _unStgM :: StateT Char IO a }   deriving (Functor, Applicative, Monad, MonadIO)  instance MonadUnique StgM where-  getUniqueSupplyM = StgM (state splitUniqSupply)-  getUniqueM = StgM (state takeUniqFromSupply)+  getUniqueSupplyM = StgM $ do { mask <- get+                               ; liftIO $! mkSplitUniqSupply mask}+  getUniqueM = StgM $ do { mask <- get+                         ; liftIO $! uniqFromMask mask} -runStgM :: UniqSupply -> StgM a -> IO a-runStgM us (StgM m) = evalStateT m us+runStgM :: Char -> StgM a -> IO a+runStgM mask (StgM m) = evalStateT m mask  stg2stg :: DynFlags                  -- includes spec of what stg-to-stg passes to do         -> Module                    -- module being compiled@@ -48,22 +50,21 @@         -> IO [StgTopBinding]        -- output program  stg2stg dflags this_mod binds-  = do  { showPass dflags "Stg2Stg"-        ; us <- mkSplitUniqSupply 'g'-+  = do  { dump_when Opt_D_dump_stg "STG:" binds+        ; showPass dflags "Stg2Stg"         -- Do the main business!-        ; binds' <- runStgM us $+        ; binds' <- runStgM 'g' $             foldM do_stg_pass binds (getStgToDo dflags) -        ; dump_when Opt_D_dump_stg "STG syntax:" binds'+        ; dump_when Opt_D_dump_stg_final "Final STG:" binds'          ; return binds'    }    where-    stg_linter what+    stg_linter unarised       | gopt Opt_DoStgLinting dflags-      = lintStgTopBindings dflags this_mod what+      = lintStgTopBindings dflags this_mod unarised       | otherwise       = \ _whodunnit _binds -> return () @@ -87,10 +88,10 @@             end_pass "StgLiftLams" binds'            StgUnarise -> do-            liftIO (dump_when Opt_D_dump_stg "Pre unarise:" binds)             us <- getUniqueSupplyM             liftIO (stg_linter False "Pre-unarise" binds)             let binds' = unarise us binds+            liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds')             liftIO (stg_linter True "Unarise" binds')             return binds'
compiler/simplStg/StgCse.hs view
@@ -78,7 +78,7 @@ These two terms are not equal as they unarise to different unboxed tuples. However if we run StgCse before Unarise, it'll think the two terms (# 1 | #) are equal, and replace one of these with a binder to-the other. That's bad -- Trac #15300.+the other. That's bad -- #15300.  Solution: do unarise first. @@ -245,8 +245,8 @@     new_id = uniqAway (ce_in_scope env) old_id     no_change = new_id == old_id     env' = env { ce_in_scope = ce_in_scope env `extendInScopeSet` new_id }-    new_env | no_change = env' { ce_subst = extendVarEnv (ce_subst env) old_id new_id }-            | otherwise = env'+    new_env | no_change = env'+            | otherwise = env' { ce_subst = extendVarEnv (ce_subst env) old_id new_id }  substBndrs :: CseEnv -> [InVar] -> (CseEnv, [OutVar]) substBndrs env bndrs = mapAccumL substBndr env bndrs
compiler/simplStg/StgLiftLams.hs view
@@ -17,8 +17,8 @@ -- Note [Late lambda lifting in STG] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- $note--- See also the <https://ghc.haskell.org/trac/ghc/wiki/LateLamLift wiki page>--- and Trac #9476.+-- See also the <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page>+-- and #9476. -- -- The basic idea behind lambda lifting is to turn locally defined functions -- into top-level functions. Free variables are then passed as additional
compiler/simplStg/StgLiftLams/Analysis.hs view
@@ -28,9 +28,9 @@ import Id import SMRep ( WordOff ) import StgSyn-import qualified StgCmmArgRep-import qualified StgCmmClosure-import qualified StgCmmLayout+import qualified GHC.StgToCmm.ArgRep  as StgToCmm.ArgRep+import qualified GHC.StgToCmm.Closure as StgToCmm.Closure+import qualified GHC.StgToCmm.Layout  as StgToCmm.Layout import Outputable import Util import VarSet@@ -81,7 +81,7 @@ --  "StgLiftLams.Analysis#clogro" and is what most of this module is ultimately --  concerned with. ----- There's a <https://ghc.haskell.org/trac/ghc/wiki/LateLamLift wiki page> with+-- There's a <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page> with -- some more background and history.  -- Note [Estimating closure growth]@@ -102,7 +102,7 @@ -- -- A more detailed treatment of computing closure growth, including examples, -- can be found in the paper referenced from the--- <https://ghc.haskell.org/trac/ghc/wiki/LateLamLift wiki page>.+-- <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page>.  llTrace :: String -> SDoc -> a -> a llTrace _ _ c = c@@ -447,7 +447,7 @@       -- to lift it       n_args         = length-        . StgCmmClosure.nonVoidIds -- void parameters don't appear in Cmm+        . StgToCmm.Closure.nonVoidIds -- void parameters don't appear in Cmm         . (dVarSetElems abs_ids ++)         . rhsLambdaBndrs       max_n_args@@ -484,26 +484,25 @@ -- | The size in words of a function closure closing over the given 'Id's, -- including the header. closureSize :: DynFlags -> [Id] -> WordOff-closureSize dflags ids = words+closureSize dflags ids = words + sTD_HDR_SIZE dflags+  -- We go through sTD_HDR_SIZE rather than fixedHdrSizeW so that we don't+  -- optimise differently when profiling is enabled.   where     (words, _, _)       -- Functions have a StdHeader (as opposed to ThunkHeader).-      -- Note that mkVirtHeadOffsets will account for profiling headers, so-      -- lifting decisions vary if we begin to profile stuff. Maybe we shouldn't-      -- do this or deactivate profiling in @dflags@?-      = StgCmmLayout.mkVirtHeapOffsets dflags StgCmmLayout.StdHeader-      . StgCmmClosure.addIdReps-      . StgCmmClosure.nonVoidIds+      = StgToCmm.Layout.mkVirtHeapOffsets dflags StgToCmm.Layout.StdHeader+      . StgToCmm.Closure.addIdReps+      . StgToCmm.Closure.nonVoidIds       $ ids  -- | The number of words a single 'Id' adds to a closure's size. -- Note that this can't handle unboxed tuples (which may still be present in -- let-no-escapes, even after Unarise), in which case--- @'StgCmmClosure.idPrimRep'@ will crash.+-- @'GHC.StgToCmm.Closure.idPrimRep'@ will crash. idClosureFootprint:: DynFlags -> Id -> WordOff idClosureFootprint dflags-  = StgCmmArgRep.argRepSizeW dflags-  . StgCmmArgRep.idArgRep+  = StgToCmm.ArgRep.argRepSizeW dflags+  . StgToCmm.ArgRep.idArgRep  -- | @closureGrowth expander sizer f fvs@ computes the closure growth in words -- as a result of lifting @f@ to top-level. If there was any growing closure
compiler/simplStg/StgLiftLams/LiftM.hs view
@@ -20,7 +20,7 @@     substOcc, isLifted, formerFreeVars, liftedIdsExpander   ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude
compiler/simplStg/StgLiftLams/Transformation.hs view
@@ -4,7 +4,7 @@ -- selecting which bindings to lambda lift by consulting 'goodToLift'. module StgLiftLams.Transformation (stgLiftLams) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -107,12 +107,12 @@ liftRhs Nothing (StgRhsClosure _ ccs upd infos body) = do   -- This RHS wasn't lifted.   withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->-    StgRhsClosure noExtSilent ccs upd bndrs' <$> liftExpr body+    StgRhsClosure noExtFieldSilent ccs upd bndrs' <$> liftExpr body liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body) = do   -- This RHS was lifted. Insert extra binders for @former_fvs@.   withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> do     let bndrs'' = dVarSetElems former_fvs ++ bndrs'-    StgRhsClosure noExtSilent ccs upd bndrs'' <$> liftExpr body+    StgRhsClosure noExtFieldSilent ccs upd bndrs'' <$> liftExpr body  liftArgs :: InStgArg -> LiftM OutStgArg liftArgs a@(StgLitArg _) = pure a@@ -142,13 +142,13 @@       body' <- liftExpr body       case mb_bind' of         Nothing -> pure body' -- withLiftedBindPairs decided to lift it and already added floats-        Just bind' -> pure (StgLet noExtSilent bind' body')+        Just bind' -> pure (StgLet noExtFieldSilent bind' body') liftExpr (StgLetNoEscape scope bind body)   = withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do       body' <- liftExpr body       case mb_bind' of         Nothing -> pprPanic "stgLiftLams" (text "Should never decide to lift LNEs")-        Just bind' -> pure (StgLetNoEscape noExtSilent bind' body')+        Just bind' -> pure (StgLetNoEscape noExtFieldSilent bind' body')  liftAlt :: LlStgAlt -> LiftM OutStgAlt liftAlt (con, infos, rhs) = withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->
compiler/simplStg/StgStats.hs view
@@ -25,7 +25,7 @@  module StgStats ( showStgStats ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude
compiler/simplStg/UnariseStg.hs view
@@ -185,16 +185,18 @@    * DataCon applications (StgRhsCon and StgConApp) don't have void arguments.     This means that it's safe to wrap `StgArg`s of DataCon applications with-    `StgCmmEnv.NonVoid`, for example.+    `GHC.StgToCmm.Env.NonVoid`, for example.    * Alt binders (binders in patterns) are always non-void.++  * Binders always have zero (for void arguments) or one PrimRep. -}  {-# LANGUAGE CPP, TupleSections #-}  module UnariseStg (unarise) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude
compiler/specialise/SpecConstr.hs view
@@ -17,7 +17,7 @@         SpecConstrAnnotation(..)     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -506,13 +506,13 @@   * Ignore specConstrCount, to make arbitrary numbers of specialisations         (see specialise)   * Specialise even for arguments that are not scrutinised in the loop-        (see argToPat; Trac #4448)+        (see argToPat; #4448)   * Only specialise on recursive types a finite number of times-        (see is_too_recursive; Trac #5550; Note [Limit recursive specialisation])+        (see is_too_recursive; #5550; Note [Limit recursive specialisation])  The flag holds only for specialising a single binding group, and NOT for nested bindings.  (So really it should be passed around explicitly-and not stored in ScEnv.)  Trac #14379 turned out to be caused by+and not stored in ScEnv.)  #14379 turned out to be caused by    f SPEC x = let g1 x = ...               in ... We force-specialise f (because of the SPEC), but that generates a specialised@@ -599,7 +599,7 @@     specialisations.  If sc_count is "no limit" then we arbitrarily     choose 10 as the limit (ugh). -See Trac #5550.   Also Trac #13623, where this test had become over-aggressive,+See #5550.   Also #13623, where this test had become over-aggressive, and we lost a wonderful specialisation that we really wanted!  Note [NoSpecConstr]@@ -746,7 +746,7 @@  This seldom happens because let-bound constructor applications are ANF-ised, but it can happen as a result of on-the-fly transformations in-SpecConstr itself.  Here is Trac #7865:+SpecConstr itself.  Here is #7865:          let {           a'_shr =@@ -946,7 +946,7 @@ extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv extendValEnv env _  Nothing   = env extendValEnv env id (Just cv)- | valueIsWorkFree cv      -- Don't duplicate work!!  Trac #7865+ | valueIsWorkFree cv      -- Don't duplicate work!!  #7865  = env { sc_vals = extendVarEnv (sc_vals env) id cv } extendValEnv env _ _ = env @@ -1048,7 +1048,7 @@ else we lose a useful specialisation for f.  This is necessary even though the simplifier has systematically replaced uses of 'x' with 'y' and 'b' with 'c' in the code.  The use of 'b' in the ValueEnv came-from outside the case.  See Trac #4908 for the live example.+from outside the case.  See #4908 for the live example.  Note [Avoiding exponential blowup] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1786,7 +1786,7 @@ The caller can, indeed must, assume this.  He should not combine in rhs_usg himself, or he'll get rhs_usg twice -- and that can lead to an exponential blowup of duplicates in the CallEnv.  This is what gave rise to the massive-performance loss in Trac #8852.+performance loss in #8852.  Note [Specialise original body] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1827,7 +1827,7 @@ when calling f_spec instead of call-by-value.  And that can result in unbounded worsening in space (cf the classic foldl vs foldl') -See Trac #3437 for a good example.+See #3437 for a good example.  The function calcSpecStrictness performs the calculation. @@ -1862,7 +1862,7 @@ BUT phantom type synonyms can mess this reasoning up,   eg   x::T b   with  type T b = Int So we apply expandTypeSynonyms to the bound Ids.-See Trac # 5458.  Yuk.+See # 5458.  Yuk.  Note [SpecConstr call patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1875,7 +1875,7 @@ former case such optimisation benign, because the rule will match more terms; but in the latter we may lose a binding of 'g1' or 'g2', and end up with a rule LHS that doesn't bind the template variables-(Trac #10602).+(#10602).  The simplifier eliminates such things, but SpecConstr itself constructs new terms by substituting.  So the 'mkCast' in the Cast case of scExpr@@ -1902,7 +1902,7 @@  Note [SpecConstr and casts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (Trac #14270) a call like+Consider (#14270) a call like      let f = e     in ... f (K @(a |> co)) ...@@ -1925,7 +1925,7 @@  I think this is very rare. -It is important (e.g. Trac #14936) that this /only/ applies to+It is important (e.g. #14936) that this /only/ applies to coercions mentioned in casts.  We don't want to be discombobulated by casts in terms!  For example, consider    f ((e1,e2) |> sym co)@@ -2049,7 +2049,7 @@      emit_trace result        | debugIsOn || hasPprDebug (sc_dflags env)-         -- Suppress this scary message for ordinary users!  Trac #5125+         -- Suppress this scary message for ordinary users!  #5125        = pprTrace "SpecConstr" msg result        | otherwise        = result
compiler/specialise/Specialise.hs view
@@ -5,15 +5,18 @@ -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ViewPatterns #-} module Specialise ( specProgram, specUnfolding ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import Id import TcType hiding( substTy ) import Type   hiding( substTy, extendTvSubstList )+import Predicate import Module( Module, HasModule(..) ) import Coercion( Coercion ) import CoreMonad@@ -25,13 +28,13 @@ import CoreSyn import Rules import CoreOpt          ( collectBindersPushingCo )-import CoreUtils        ( exprIsTrivial, applyTypeToArgs, mkCast )+import CoreUtils        ( exprIsTrivial, mkCast, exprType ) import CoreFVs import CoreArity        ( etaExpandToJoinPointRule ) import UniqSupply import Name import MkId             ( voidArgId, voidPrimId )-import Maybes           ( catMaybes, isJust )+import Maybes           ( mapMaybe, isJust ) import MonadUtils       ( foldlM ) import BasicTypes import HscTypes@@ -42,6 +45,7 @@ import FastString import State import UniqDFM+import TyCoRep (TyCoBinder (..))  import Control.Monad import qualified Control.Monad.Fail as MonadFail@@ -628,9 +632,193 @@ -fno-cross-module-specialise option was introduced to allow users to being bitten by such instances to revert to the pre-7.10 behavior. -See Trac #10491+See #10491 -} +-- | An argument that we might want to specialise.+-- See Note [Specialising Calls] for the nitty gritty details.+data SpecArg+  =+    -- | Type arguments that should be specialised, due to appearing+    -- free in the type of a 'SpecDict'.+    SpecType Type+    -- | Type arguments that should remain polymorphic.+  | UnspecType+    -- | Dictionaries that should be specialised.+  | SpecDict DictExpr+    -- | Value arguments that should not be specialised.+  | UnspecArg++instance Outputable SpecArg where+  ppr (SpecType t) = text "SpecType" <+> ppr t+  ppr UnspecType   = text "UnspecType"+  ppr (SpecDict d) = text "SpecDict" <+> ppr d+  ppr UnspecArg    = text "UnspecArg"++getSpecDicts :: [SpecArg] -> [DictExpr]+getSpecDicts = mapMaybe go+  where+    go (SpecDict d) = Just d+    go _            = Nothing++getSpecTypes :: [SpecArg] -> [Type]+getSpecTypes = mapMaybe go+  where+    go (SpecType t) = Just t+    go _            = Nothing++isUnspecArg :: SpecArg -> Bool+isUnspecArg UnspecArg  = True+isUnspecArg UnspecType = True+isUnspecArg _          = False++isValueArg :: SpecArg -> Bool+isValueArg UnspecArg    = True+isValueArg (SpecDict _) = True+isValueArg _            = False++-- | Given binders from an original function 'f', and the 'SpecArg's+-- corresponding to its usage, compute everything necessary to build+-- a specialisation.+--+-- We will use a running example. Consider the function+--+--    foo :: forall a b. Eq a => Int -> blah+--    foo @a @b dEqA i = blah+--+-- which is called with the 'CallInfo'+--+--    [SpecType T1, UnspecType, SpecDict dEqT1, UnspecArg]+--+-- We'd eventually like to build the RULE+--+--    RULE "SPEC foo @T1 _"+--      forall @a @b (dEqA' :: Eq a).+--        foo @T1 @b dEqA' = $sfoo @b+--+-- and the specialisation '$sfoo'+--+--    $sfoo :: forall b. Int -> blah+--    $sfoo @b = \i -> SUBST[a->T1, dEqA->dEqA'] blah+--+-- The cases for 'specHeader' below are presented in the same order as this+-- running example. The result of 'specHeader' for this example is as follows:+--+--    ( -- Returned arguments+--      env + [a -> T1, deqA -> dEqA']+--    , []+--+--      -- RULE helpers+--    , [b, dx', i]+--    , [T1, b, dx', i]+--+--      -- Specialised function helpers+--    , [b, i]+--    , [dx]+--    , [T1, b, dx_spec, i]+--    )+specHeader+     :: SpecEnv+     -> [CoreBndr]  -- The binders from the original function 'f'+     -> [SpecArg]   -- From the CallInfo+     -> SpecM ( -- Returned arguments+                SpecEnv      -- Substitution to apply to the body of 'f'+              , [CoreBndr]   -- All the remaining unspecialised args from the original function 'f'++                -- RULE helpers+              , [CoreBndr]   -- Binders for the RULE+              , [CoreArg]    -- Args for the LHS of the rule++                -- Specialised function helpers+              , [CoreBndr]   -- Binders for $sf+              , [DictBind]   -- Auxiliary dictionary bindings+              , [CoreExpr]   -- Specialised arguments for unfolding+              )++-- We want to specialise on type 'T1', and so we must construct a substitution+-- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding+-- details.+specHeader env (bndr : bndrs) (SpecType t : args)+  = do { let env' = extendTvSubstList env [(bndr, t)]+       ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)+            <- specHeader env' bndrs args+       ; pure ( env''+              , unused_bndrs+              , rule_bs+              , Type t : rule_es+              , bs'+              , dx+              , Type t : spec_args+              )+       }++-- Next we have a type that we don't want to specialise. We need to perform+-- a substitution on it (in case the type refers to 'a'). Additionally, we need+-- to produce a binder, LHS argument and RHS argument for the resulting rule,+-- /and/ a binder for the specialised body.+specHeader env (bndr : bndrs) (UnspecType : args)+  = do { let (env', bndr') = substBndr env bndr+       ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)+            <- specHeader env' bndrs args+       ; pure ( env''+              , unused_bndrs+              , bndr' : rule_bs+              , varToCoreExpr bndr' : rule_es+              , bndr' : bs'+              , dx+              , varToCoreExpr bndr' : spec_args+              )+       }++-- Next we want to specialise the 'Eq a' dict away. We need to construct+-- a wildcard binder to match the dictionary (See Note [Specialising Calls] for+-- the nitty-gritty), as a LHS rule and unfolding details.+specHeader env (bndr : bndrs) (SpecDict d : args)+  = do { inst_dict_id <- newDictBndr env bndr+       ; let (rhs_env2, dx_binds, spec_dict_args')+                = bindAuxiliaryDicts env [bndr] [d] [inst_dict_id]+       ; (env', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)+             <- specHeader rhs_env2 bndrs args+       ; pure ( env'+              , unused_bndrs+              -- See Note [Evidence foralls]+              , exprFreeIdsList (varToCoreExpr inst_dict_id) ++ rule_bs+              , varToCoreExpr inst_dict_id : rule_es+              , bs'+              , dx_binds ++ dx+              , spec_dict_args' ++ spec_args+              )+       }++-- Finally, we have the unspecialised argument 'i'. We need to produce+-- a binder, LHS and RHS argument for the RULE, and a binder for the+-- specialised body.+--+-- NB: Calls to 'specHeader' will trim off any trailing 'UnspecArg's, which is+-- why 'i' doesn't appear in our RULE above. But we have no guarantee that+-- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so+-- this case must be here.+specHeader env (bndr : bndrs) (UnspecArg : args)+  = do { let (env', bndr') = substBndr env bndr+       ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)+             <- specHeader env' bndrs args+       ; pure ( env''+              , unused_bndrs+              , bndr' : rule_bs+              , varToCoreExpr bndr' : rule_es+              , bndr' : bs'+              , dx+              , varToCoreExpr bndr' : spec_args+              )+       }++-- Return all remaining binders from the original function. These have the+-- invariant that they should all correspond to unspecialised arguments, so+-- it's safe to stop processing at this point.+specHeader env bndrs [] = pure (env, bndrs, [], [], [], [], [])+specHeader env [] _     = pure (env, [], [], [], [], [], [])++ -- | Specialise a set of calls to imported bindings specImports :: DynFlags             -> Module@@ -730,28 +918,35 @@         ; return (rules2 ++ rules1, final_binds) } -  |  warnMissingSpecs dflags callers-  = do { warnMsg (vcat [ hang (text "Could not specialise imported function" <+> quotes (ppr fn))-                            2 (vcat [ text "when specialising" <+> quotes (ppr caller)-                                    | caller <- callers])-                      , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn))-                      , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ])-       ; return ([], []) }+  | otherwise = do { tryWarnMissingSpecs dflags callers fn calls_for_fn+                   ; return ([], [])} -  | otherwise-  = return ([], [])   where     unfolding = realIdUnfolding fn   -- We want to see the unfolding even for loop breakers -warnMissingSpecs :: DynFlags -> [Id] -> Bool+-- | Returns whether or not to show a missed-spec warning.+-- If -Wall-missed-specializations is on, show the warning.+-- Otherwise, if -Wmissed-specializations is on, only show a warning+-- if there is at least one imported function being specialized,+-- and if all imported functions are marked with an inline pragma+-- Use the most specific warning as the reason.+tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM () -- See Note [Warning about missed specialisations]-warnMissingSpecs dflags callers-  | wopt Opt_WarnAllMissedSpecs dflags = True-  | not (wopt Opt_WarnMissedSpecs dflags) = False-  | null callers                       = False-  | otherwise                          = all has_inline_prag callers+tryWarnMissingSpecs dflags callers fn calls_for_fn+  | wopt Opt_WarnMissedSpecs dflags+    && not (null callers)+    && allCallersInlined                  = doWarn $ Reason Opt_WarnMissedSpecs+  | wopt Opt_WarnAllMissedSpecs dflags    = doWarn $ Reason Opt_WarnAllMissedSpecs+  | otherwise                             = return ()   where-    has_inline_prag id = isAnyInlinePragma (idInlinePragma id)+    allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers+    doWarn reason =+      warnMsg reason+        (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn))+                2 (vcat [ text "when specialising" <+> quotes (ppr caller)+                        | caller <- callers])+          , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn))+          , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ])  wantSpecImport :: DynFlags -> Unfolding -> Bool -- See Note [Specialise imported INLINABLE things]@@ -793,7 +988,7 @@ but with -fspecialise-aggressively we add  * Anything with an unfolding template -Trac #8874 has a good example of why we want to auto-specialise DFuns.+#8874 has a good example of why we want to auto-specialise DFuns.  We have the -fspecialise-aggressively flag (usually off), because we risk lots of orphan modules from over-vigorous specialisation.@@ -1164,8 +1359,7 @@  specCalls mb_mod env existing_rules calls_for_me fn rhs         -- The first case is the interesting one-  |  rhs_tyvars `lengthIs`      n_tyvars -- Rhs of fn's defn has right number of big lambdas-  && rhs_bndrs1 `lengthAtLeast` n_dicts -- and enough dict args+  |  callSpecArity pis <= fn_arity      -- See Note [Specialisation Must Preserve Sharing]   && notNull calls_for_me               -- And there are some calls to specialise   && not (isNeverActive (idInlineActivation fn))         -- Don't specialise NOINLINE things@@ -1186,15 +1380,14 @@     -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $     return ([], [], emptyUDs)   where-    _trace_doc = sep [ ppr rhs_tyvars, ppr n_tyvars-                     , ppr rhs_bndrs, ppr n_dicts+    _trace_doc = sep [ ppr rhs_tyvars, ppr rhs_bndrs                      , ppr (idInlineActivation fn) ]      fn_type                 = idType fn     fn_arity                = idArity fn     fn_unf                  = realIdUnfolding fn  -- Ignore loop-breaker-ness here-    (tyvars, theta, _)      = tcSplitSigmaTy fn_type-    n_tyvars                = length tyvars+    pis                     = fst $ splitPiTys fn_type+    theta                   = getTheta pis     n_dicts                 = length theta     inl_prag                = idInlinePragma fn     inl_act                 = inlinePragmaActivation inl_prag@@ -1205,10 +1398,7 @@      (rhs_bndrs, rhs_body)      = collectBindersPushingCo rhs                                  -- See Note [Account for casts in binding]-    (rhs_tyvars, rhs_bndrs1)   = span isTyVar rhs_bndrs-    (rhs_dict_ids, rhs_bndrs2) = splitAt n_dicts rhs_bndrs1-    body                       = mkLams rhs_bndrs2 rhs_body-                                 -- Glue back on the non-dict lambdas+    rhs_tyvars = filter isTyVar rhs_bndrs      in_scope = CoreSubst.substInScope (se_subst env) @@ -1220,59 +1410,19 @@          -- NB: we look both in the new_rules (generated by this invocation          --     of specCalls), and in existing_rules (passed in to specCalls) -    mk_ty_args :: [Maybe Type] -> [TyVar] -> [CoreExpr]-    mk_ty_args [] poly_tvs-      = ASSERT( null poly_tvs ) []-    mk_ty_args (Nothing : call_ts) (poly_tv : poly_tvs)-      = Type (mkTyVarTy poly_tv) : mk_ty_args call_ts poly_tvs-    mk_ty_args (Just ty : call_ts) poly_tvs-      = Type ty : mk_ty_args call_ts poly_tvs-    mk_ty_args (Nothing : _) [] = panic "mk_ty_args"-     ----------------------------------------------------------         -- Specialise to one particular call pattern     spec_call :: SpecInfo                         -- Accumulating parameter               -> CallInfo                         -- Call instance               -> SpecM SpecInfo     spec_call spec_acc@(rules_acc, pairs_acc, uds_acc)-              (CI { ci_key = CallKey call_ts, ci_args = call_ds })-      = ASSERT( call_ts `lengthIs` n_tyvars  && call_ds `lengthIs` n_dicts )--        -- Suppose f's defn is  f = /\ a b c -> \ d1 d2 -> rhs-        -- Suppose the call is for f [Just t1, Nothing, Just t3] [dx1, dx2]--        -- Construct the new binding-        --      f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b -> rhs)-        -- PLUS the rule-        --      RULE "SPEC f" forall b d1' d2'. f b d1' d2' = f1 b-        --      In the rule, d1' and d2' are just wildcards, not used in the RHS-        -- PLUS the usage-details-        --      { d1' = dx1; d2' = dx2 }-        -- where d1', d2' are cloned versions of d1,d2, with the type substitution-        -- applied.  These auxiliary bindings just avoid duplication of dx1, dx2-        ---        -- Note that the substitution is applied to the whole thing.-        -- This is convenient, but just slightly fragile.  Notably:-        --      * There had better be no name clashes in a/b/c-        do { let-                -- poly_tyvars = [b] in the example above-                -- spec_tyvars = [a,c]-                -- ty_args     = [t1,b,t3]-                spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts]-                env1          = extendTvSubstList env spec_tv_binds-                (rhs_env, poly_tyvars) = substBndrs env1-                                            [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts]--             -- Clone rhs_dicts, including instantiating their types-           ; inst_dict_ids <- mapM (newDictBndr rhs_env) rhs_dict_ids-           ; let (rhs_env2, dx_binds, spec_dict_args)-                            = bindAuxiliaryDicts rhs_env rhs_dict_ids call_ds inst_dict_ids-                 ty_args    = mk_ty_args call_ts poly_tyvars-                 ev_args    = map varToCoreExpr inst_dict_ids  -- ev_args, ev_bndrs:-                 ev_bndrs   = exprsFreeIdsList ev_args         -- See Note [Evidence foralls]-                 rule_args  = ty_args     ++ ev_args-                 rule_bndrs = poly_tyvars ++ ev_bndrs+              (CI { ci_key = call_args, ci_arity = call_arity })+      = ASSERT(call_arity <= fn_arity) +        -- See Note [Specialising Calls]+        do { (rhs_env2, unused_bndrs, rule_bndrs, rule_args, unspec_bndrs, dx_binds, spec_args)+               <- specHeader env rhs_bndrs $ dropWhileEndLE isUnspecArg call_args+           ; let rhs_body' = mkLams unused_bndrs rhs_body            ; dflags <- getDynFlags            ; if already_covered dflags rules_acc rule_args              then return spec_acc@@ -1281,25 +1431,28 @@                   --                           , ppr dx_binds ]) $                   do            {    -- Figure out the type of the specialised function-             let body_ty = applyTypeToArgs rhs fn_type rule_args-                 (lam_args, app_args)           -- Add a dummy argument if body_ty is unlifted+             let body = mkLams unspec_bndrs rhs_body'+                 body_ty = substTy rhs_env2 $ exprType body+                 (lam_extra_args, app_args)     -- See Note [Specialisations Must Be Lifted]                    | isUnliftedType body_ty     -- C.f. WwLib.mkWorkerArgs                    , not (isJoinId fn)-                   = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [voidPrimId])-                   | otherwise = (poly_tyvars, poly_tyvars)-                 spec_id_ty = mkLamTypes lam_args body_ty+                   = ([voidArgId], voidPrimId : unspec_bndrs)+                   | otherwise = ([], unspec_bndrs)                  join_arity_change = length app_args - length rule_args                  spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn                                  = Just (orig_join_arity + join_arity_change)                                  | otherwise                                  = Nothing +           ; (spec_rhs, rhs_uds) <- specExpr rhs_env2 (mkLams lam_extra_args body)+           ; let spec_id_ty = exprType spec_rhs            ; spec_f <- newSpecIdSM fn spec_id_ty spec_join_arity-           ; (spec_rhs, rhs_uds) <- specExpr rhs_env2 (mkLams lam_args body)            ; this_mod <- getModule            ; let                 -- The rule to put in the function's specialisation is:-                --      forall b, d1',d2'.  f t1 b t3 d1' d2' = f1 b+                --      forall x @b d1' d2'.+                --          f x @T1 @b @T2 d1' d2' = f1 x @b+                -- See Note [Specialising Calls]                 herald = case mb_mod of                            Nothing        -- Specialising local fn                                -> text "SPEC"@@ -1308,7 +1461,7 @@                  rule_name = mkFastString $ showSDoc dflags $                             herald <+> ftext (occNameFS (getOccName fn))-                                   <+> hsep (map ppr_call_key_ty call_ts)+                                   <+> hsep (mapMaybe ppr_call_key_ty call_args)                             -- This name ends up in interface files, so use occNameString.                             -- Otherwise uniques end up there, making builds                             -- less deterministic (See #4012 comment:61 ff)@@ -1331,6 +1484,7 @@                       Nothing -> rule_wout_eta                  -- Add the { d1' = dx1; d2' = dx2 } usage stuff+                -- See Note [Specialising Calls]                 spec_uds = foldr consDictBind rhs_uds dx_binds                  --------------------------------------@@ -1345,11 +1499,9 @@                   = (inl_prag { inl_inline = NoUserInline }, noUnfolding)                    | otherwise-                  = (inl_prag, specUnfolding dflags poly_tyvars spec_app-                                             arity_decrease fn_unf)+                  = (inl_prag, specUnfolding dflags unspec_bndrs spec_app n_dicts fn_unf) -                arity_decrease = length spec_dict_args-                spec_app e = (e `mkApps` ty_args) `mkApps` spec_dict_args+                spec_app e = e `mkApps` spec_args                  --------------------------------------                 -- Adding arity information just propagates it a bit faster@@ -1361,13 +1513,116 @@                                         `setIdUnfolding`  spec_unf                                         `asJoinId_maybe`  spec_join_arity -           ; return ( spec_rule                  : rules_acc+                _rule_trace_doc = vcat [ ppr spec_f, ppr fn_type, ppr spec_id_ty+                                       , ppr rhs_bndrs, ppr call_args+                                       , ppr spec_rule+                                       ]++           ; -- pprTrace "spec_call: rule" _rule_trace_doc+             return ( spec_rule                  : rules_acc                     , (spec_f_w_arity, spec_rhs) : pairs_acc                     , spec_uds           `plusUDs` uds_acc                     ) } } -{- Note [Account for casts in binding]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Specialisation Must Preserve Sharing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a function:++    f :: forall a. Eq a => a -> blah+    f =+      if expensive+         then f1+         else f2++As written, all calls to 'f' will share 'expensive'. But if we specialise 'f'+at 'Int', eg:++    $sfInt = SUBST[a->Int,dict->dEqInt] (if expensive then f1 else f2)++    RULE "SPEC f"+      forall (d :: Eq Int).+        f Int _ = $sfIntf++We've now lost sharing between 'f' and '$sfInt' for 'expensive'. Yikes!++To avoid this, we only generate specialisations for functions whose arity is+enough to bind all of the arguments we need to specialise.  This ensures our+specialised functions don't do any work before receiving all of their dicts,+and thus avoids the 'f' case above.++Note [Specialisations Must Be Lifted]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a function 'f':++    f = forall a. Eq a => Array# a++used like++    case x of+      True -> ...f @Int dEqInt...+      False -> 0++Naively, we might generate an (expensive) specialisation++    $sfInt :: Array# Int++even in the case that @x = False@! Instead, we add a dummy 'Void#' argument to+the specialisation '$sfInt' ($sfInt :: Void# -> Array# Int) in order to+preserve laziness.++Note [Specialising Calls]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have a function:++    f :: Int -> forall a b c. (Foo a, Foo c) => Bar -> Qux+    f = \x -> /\ a b c -> \d1 d2 bar -> rhs++and suppose it is called at:++    f 7 @T1 @T2 @T3 dFooT1 dFooT3 bar++This call is described as a 'CallInfo' whose 'ci_key' is++    [ UnspecArg, SpecType T1, UnspecType, SpecType T3, SpecDict dFooT1+    , SpecDict dFooT3, UnspecArg ]++Why are 'a' and 'c' identified as 'SpecType', while 'b' is 'UnspecType'?+Because we must specialise the function on type variables that appear+free in its *dictionary* arguments; but not on type variables that do not+appear in any dictionaries, i.e. are fully polymorphic.++Because this call has dictionaries applied, we'd like to specialise+the call on any type argument that appears free in those dictionaries.+In this case, those are (a ~ T1, c ~ T3).++As a result, we'd like to generate a function:++    $sf :: Int -> forall b. Bar -> Qux+    $sf = SUBST[a->T1, c->T3, d1->d1', d2->d2'] (\x -> /\ b -> \bar -> rhs)++Note that the substitution is applied to the whole thing.  This is+convenient, but just slightly fragile.  Notably:+  * There had better be no name clashes in a/b/c++We must construct a rewrite rule:++    RULE "SPEC f @T1 _ @T3"+      forall (x :: Int) (@b :: Type) (d1' :: Foo T1) (d2' :: Foo T3).+        f x @T1 @b @T3 d1' d2' = $sf x @b++In the rule, d1' and d2' are just wildcards, not used in the RHS.  Note+additionally that 'bar' isn't captured by this rule --- we bind only+enough etas in order to capture all of the *specialised* arguments.++Finally, we must also construct the usage-details++     { d1' = dx1; d2' = dx2 }++where d1', d2' are cloned versions of d1,d2, with the type substitution+applied.  These auxiliary bindings just avoid duplication of dx1, dx2.++Note [Account for casts in binding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider    f :: Eq a => a -> IO ()    {-# INLINABLE f@@ -1384,7 +1639,7 @@  Note [Evidence foralls] ~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose (Trac #12212) that we are specialising+Suppose (#12212) that we are specialising    f :: forall a b. (Num a, F a ~ F b) => blah with a=b=Int. Then the RULE will be something like    RULE forall (d:Num Int) (g :: F Int ~ F Int).@@ -1506,7 +1761,7 @@ Note [Avoiding loops] ~~~~~~~~~~~~~~~~~~~~~ When specialising /dictionary functions/ we must be very careful to-avoid building loops. Here is an example that bit us badly: Trac #3591+avoid building loops. Here is an example that bit us badly: #3591       class Eq a => C a      instance Eq [a] => C [a]@@ -1547,7 +1802,7 @@  -------------- Here's another example, this time for an imported dfun, so the call-to filterCalls is in specImports (Trac #13429). Suppose we have+to filterCalls is in specImports (#13429). Suppose we have   class Monoid v => C v a where ...  We start with a call@@ -1785,7 +2040,7 @@    This particular example had a huge effect on the call to replicateM_    in nofib/shootout/n-body. -Why (b): discard INLINABLE pragmas? See Trac #4874 for persuasive examples.+Why (b): discard INLINABLE pragmas? See #4874 for persuasive examples. Suppose we have     {-# INLINABLE f #-}     f :: Ord a => [a] -> Int@@ -1803,7 +2058,7 @@ a complete solution; ignoring specialisation for now, INLINABLE functions don't get properly strictness analysed, for example. But it works well for examples involving specialisation, which is the dominant use of-INLINABLE.  See Trac #4874.+INLINABLE.  See #4874.   ************************************************************************@@ -1881,16 +2136,14 @@   -- These dups are eliminated by already_covered in specCalls  data CallInfo-  = CI { ci_key  :: CallKey     -- Type arguments-       , ci_args :: [DictExpr]  -- Dictionary arguments-       , ci_fvs  :: VarSet      -- Free vars of the ci_key and ci_args+  = CI { ci_key  :: [SpecArg]   -- All arguments+       , ci_arity :: Int        -- The number of variables necessary to bind+                                -- all of the specialised arguments+       , ci_fvs  :: VarSet      -- Free vars of the ci_key                                 -- call (including tyvars)                                 -- [*not* include the main id itself, of course]     } -newtype CallKey   = CallKey [Maybe Type]-  -- Nothing => unconstrained type argument- type DictExpr = CoreExpr  ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet@@ -1904,16 +2157,15 @@ pprCallInfo fn (CI { ci_key = key })   = ppr fn <+> ppr key -ppr_call_key_ty :: Maybe Type -> SDoc-ppr_call_key_ty Nothing   = char '_'-ppr_call_key_ty (Just ty) = char '@' <+> pprParendType ty--instance Outputable CallKey where-  ppr (CallKey ts) = brackets (fsep (map ppr_call_key_ty ts))+ppr_call_key_ty :: SpecArg -> Maybe SDoc+ppr_call_key_ty (SpecType ty) = Just $ char '@' <+> pprParendType ty+ppr_call_key_ty UnspecType    = Just $ char '_'+ppr_call_key_ty (SpecDict _)  = Nothing+ppr_call_key_ty UnspecArg     = Nothing  instance Outputable CallInfo where-  ppr (CI { ci_key = key, ci_args = args, ci_fvs = fvs })-    = text "CI" <> braces (hsep [ ppr key, ppr args, ppr fvs ])+  ppr (CI { ci_key = key, ci_fvs = fvs })+    = text "CI" <> braces (hsep [ fsep (mapMaybe ppr_call_key_ty key), ppr fvs ])  unionCalls :: CallDetails -> CallDetails -> CallDetails unionCalls c1 c2 = plusDVarEnv_C unionCallInfoSet c1 c2@@ -1930,19 +2182,31 @@  callInfoFVs :: CallInfoSet -> VarSet callInfoFVs (CIS _ call_info) =-  foldrBag (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info+  foldr (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info +computeArity :: [SpecArg] -> Int+computeArity = length . filter isValueArg . dropWhileEndLE isUnspecArg++callSpecArity :: [TyCoBinder] -> Int+callSpecArity = length . filter (not . isNamedBinder) . dropWhileEndLE isVisibleBinder++getTheta :: [TyCoBinder] -> [PredType]+getTheta = fmap tyBinderType . filter isInvisibleBinder . filter (not . isNamedBinder)++ -------------------------------------------------------------singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails-singleCall id tys dicts+singleCall :: Id -> [SpecArg] -> UsageDetails+singleCall id args   = MkUD {ud_binds = emptyBag,           ud_calls = unitDVarEnv id $ CIS id $-                     unitBag (CI { ci_key = CallKey tys-                                 , ci_args = dicts+                     unitBag (CI { ci_key  = args -- used to be tys+                                 , ci_arity = computeArity args                                  , ci_fvs  = call_fvs }) }   where+    tys      = getSpecTypes args+    dicts    = getSpecDicts args     call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs-    tys_fvs  = tyCoVarsOfTypes (catMaybes tys)+    tys_fvs  = tyCoVarsOfTypes tys         -- The type args (tys) are guaranteed to be part of the dictionary         -- types, because they are just the constrained types,         -- and the dictionary is therefore sure to be bound@@ -1966,8 +2230,8 @@   = emptyUDs    |  not (all type_determines_value theta)-  || not (spec_tys `lengthIs` n_tyvars)-  || not ( dicts   `lengthIs` n_dicts)+  || not (computeArity ci_key <= idArity f)+  || not (length dicts == length theta)   || not (any (interestingDict env) dicts)    -- Note [Interesting dictionary arguments]   -- See also Note [Specialisations already covered]   = -- pprTrace "mkCallUDs: discarding" _trace_doc@@ -1975,27 +2239,28 @@    | otherwise   = -- pprTrace "mkCallUDs: keeping" _trace_doc-    singleCall f spec_tys dicts+    singleCall f ci_key   where-    _trace_doc = vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts-                      , ppr (map (interestingDict env) dicts)]-    (tyvars, theta, _)      = tcSplitSigmaTy (idType f)-    constrained_tyvars      = tyCoVarsOfTypes theta-    n_tyvars                = length tyvars-    n_dicts                 = length theta--    spec_tys = [mk_spec_ty tv ty | (tv, ty) <- tyvars `type_zip` args]-    dicts    = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]+    _trace_doc = vcat [ppr f, ppr args, ppr (map (interestingDict env) dicts)]+    pis                = fst $ splitPiTys $ idType f+    theta              = getTheta pis+    constrained_tyvars = tyCoVarsOfTypes theta -    -- ignores Coercion arguments-    type_zip :: [TyVar] -> [CoreExpr] -> [(TyVar, Type)]-    type_zip tvs      (Coercion _ : args) = type_zip tvs args-    type_zip (tv:tvs) (Type ty : args)    = (tv, ty) : type_zip tvs args-    type_zip _        _                   = []+    ci_key :: [SpecArg]+    ci_key = fmap (\(t, a) ->+      case t of+        Named (binderVar -> tyVar)+          |  tyVar `elemVarSet` constrained_tyvars+          -> case a of+              Type ty -> SpecType ty+              _ -> pprPanic "ci_key" $ ppr a+          |  otherwise+          -> UnspecType+        Anon InvisArg _ -> SpecDict a+        Anon VisArg _ -> UnspecArg+                ) $ zip pis args -    mk_spec_ty tyvar ty-        | tyvar `elemVarSet` constrained_tyvars = Just ty-        | otherwise                             = Nothing+    dicts = getSpecDicts ci_key      want_calls_for f = isLocalId f || isJust (maybeUnfoldingTemplate (realIdUnfolding f))          -- For imported things, we gather call instances if@@ -2009,7 +2274,7 @@             ClassPred cls _ -> not (isIPClass cls)  -- Superclasses can't be IPs             EqPred {}       -> True             IrredPred {}    -> True   -- Things like (D []) where D is a-                                      -- Constraint-ranged family; Trac #7785+                                      -- Constraint-ranged family; #7785             ForAllPred {}   -> True  {-@@ -2018,7 +2283,7 @@ Only specialise if all overloading is on non-IP *class* params, because these are the ones whose *type* determines their *value*.  In parrticular, with implicit params, the type args *don't* say what the-value of the implicit param is!  See Trac #7101+value of the implicit param is!  See #7101  However, consider          type family D (v::*->*) :: Constraint@@ -2032,7 +2297,7 @@ type-family constraint like (D a).  Well, no.  We don't allow         type instance D Maybe = ?x:Int Hence the IrredPred case in type_determines_value.-See Trac #7785.+See #7785.  Note [Interesting dictionary arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2058,7 +2323,7 @@  We accidentally lost accurate tracking of local variables for a long time, because cloned variables don't have unfoldings. But makes a-massive difference in a few cases, eg Trac #5113. For nofib as a+massive difference in a few cases, eg #5113. For nofib as a whole it's only a small win: 2.2% improvement in allocation for ansi, 1.2% for bspt, but mostly 0.0!  Average 0.1% increase in binary size. -}@@ -2086,7 +2351,7 @@  ----------------------------- _dictBindBndrs :: Bag DictBind -> [Id]-_dictBindBndrs dbs = foldrBag ((++) . bindersOf . fst) [] dbs+_dictBindBndrs dbs = foldr ((++) . bindersOf . fst) [] dbs  -- | Construct a 'DictBind' from a 'CoreBind' mkDB :: CoreBind -> DictBind@@ -2117,7 +2382,7 @@         --         involving an imported dfun.  We must know whether         --         a dictionary binding depends on an imported dfun,         --         in case we try to specialise that imported dfun-        --         Trac #13429 illustrates+        --         #13429 illustrates  -- | Flatten a set of "dumped" 'DictBind's, and some other binding -- pairs, into a single recursive binding.@@ -2125,7 +2390,7 @@ recWithDumpedDicts pairs dbs   = (Rec bindings, fvs)   where-    (bindings, fvs) = foldrBag add+    (bindings, fvs) = foldr add                                ([], emptyVarSet)                                (dbs `snocBag` mkDB (Rec pairs))     add (NonRec b r, fvs') (pairs, fvs) =@@ -2149,13 +2414,13 @@  wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind] wrapDictBinds dbs binds-  = foldrBag add binds dbs+  = foldr add binds dbs   where     add (bind,_) binds = bind : binds  wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr wrapDictBindsE dbs expr-  = foldrBag add expr dbs+  = foldr add expr dbs   where     add (bind,_) expr = Let bind expr @@ -2214,7 +2479,7 @@ filterCalls (CIS fn call_bag) dbs   = filter ok_call (bagToList call_bag)   where-    dump_set = foldlBag go (unitVarSet fn) dbs+    dump_set = foldl' go (unitVarSet fn) dbs       -- This dump-set could also be computed by splitDictBinds       --   (_,_,dump_set) = splitDictBinds dbs {fn}       -- But this variant is shorter@@ -2234,8 +2499,8 @@ --   * free_dbs does not depend on bndrs --   * dump_set = bndrs `union` bndrs(dump_dbs) splitDictBinds dbs bndr_set-   = foldlBag split_db (emptyBag, emptyBag, bndr_set) dbs-                -- Important that it's foldl not foldr;+   = foldl' split_db (emptyBag, emptyBag, bndr_set) dbs+                -- Important that it's foldl' not foldr;                 -- we're accumulating the set of dumped ids in dump_set    where     split_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)@@ -2267,16 +2532,13 @@ ************************************************************************ -} -newtype SpecM a = SpecM (State SpecState a)+newtype SpecM a = SpecM (State SpecState a) deriving (Functor)  data SpecState = SpecState {                      spec_uniq_supply :: UniqSupply,                      spec_module :: Module,                      spec_dflags :: DynFlags                  }--instance Functor SpecM where-    fmap = liftM  instance Applicative SpecM where     pure x = SpecM $ return x
compiler/stgSyn/CoreToStg.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, DeriveFunctor #-}  -- -- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998@@ -13,7 +13,7 @@  module CoreToStg ( coreToStg ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -50,7 +50,7 @@  import Data.List.NonEmpty (nonEmpty, toList) import Data.Maybe    (fromMaybe)-import Control.Monad (liftM, ap)+import Control.Monad (ap)  -- Note [Live vs free] -- ~~~~~~~~~~~~~~~~~~~@@ -115,7 +115,7 @@ -- bitmap in each info table describing which entries of this table the closure -- references. ----- See also: Commentary/Rts/Storage/GC/CAFs on the GHC Wiki.+-- See also: commentary/rts/storage/gc/CAFs on the GHC Wiki.  -- Note [What is a non-escaping let] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -198,6 +198,26 @@ --                 do we set CCCS from it; so we just slam in --                 dontCareCostCentre. +-- Note [Coercion tokens]+-- ~~~~~~~~~~~~~~~~~~~~~~+-- In coreToStgArgs, we drop type arguments completely, but we replace+-- coercions with a special coercionToken# placeholder. Why? Consider:+--+--   f :: forall a. Int ~# Bool -> a+--   f = /\a. \(co :: Int ~# Bool) -> error "impossible"+--+-- If we erased the coercion argument completely, we’d end up with just+-- f = error "impossible", but then f `seq` () would be ⊥!+--+-- This is an artificial example, but back in the day we *did* treat+-- coercion lambdas like type lambdas, and we had bug reports as a+-- result. So now we treat coercion lambdas like value lambdas, but we+-- treat coercions themselves as zero-width arguments — coercionToken#+-- has representation VoidRep — which gets the best of both worlds.+--+-- (For the gory details, see also the (unpublished) paper, “Practical+-- aspects of evidence-based compilation in System FC.”)+ -- -------------------------------------------------------------- -- Setting variable info: top-level, binds, RHSs -- --------------------------------------------------------------@@ -263,12 +283,12 @@         how_bound = LetBound TopLet $! manifestArity rhs          (stg_rhs, ccs') =-            initCts env $+            initCts dflags env $               coreToTopStgRhs dflags ccs this_mod (id,rhs)          bind = StgTopLifted $ StgNonRec id stg_rhs     in-    assertConsistentCaInfo dflags id bind (ppr bind)+    assertConsistentCafInfo dflags id bind (ppr bind)       -- NB: previously the assertion printed 'rhs' and 'bind'       --     as well as 'id', but that led to a black hole       --     where printing the assertion error tripped the@@ -286,7 +306,7 @@          -- generate StgTopBindings and CAF cost centres created for CAFs         (ccs', stg_rhss)-          = initCts env' $ do+          = initCts dflags env' $ do                mapAccumLM (\ccs rhs -> do                             (rhs', ccs') <-                               coreToTopStgRhs dflags ccs this_mod rhs@@ -296,17 +316,17 @@          bind = StgTopLifted $ StgRec (zip binders stg_rhss)     in-    assertConsistentCaInfo dflags (head binders) bind (ppr binders)+    assertConsistentCafInfo dflags (head binders) bind (ppr binders)     (env', ccs', bind)  -- | CAF consistency issues will generally result in segfaults and are quite -- difficult to debug (see #16846). We enable checking of the -- 'consistentCafInfo' invariant with @-dstg-lint@ to increase the chance that -- we catch these issues.-assertConsistentCaInfo :: DynFlags -> Id -> StgTopBinding -> SDoc -> a -> a-assertConsistentCaInfo dflags id bind err_doc result+assertConsistentCafInfo :: DynFlags -> Id -> StgTopBinding -> SDoc -> a -> a+assertConsistentCafInfo dflags id bind err_doc result   | gopt Opt_DoStgLinting dflags || debugIsOn-  , not $ consistentCafInfo id bind = pprPanic "assertConsistentCaInfo" err_doc+  , not $ consistentCafInfo id bind = pprPanic "assertConsistentCafInfo" err_doc   | otherwise = result  -- Assertion helper: this checks that the CafInfo on the Id matches@@ -345,7 +365,7 @@         -- It's vital that the arity on a top-level Id matches         -- the arity of the generated STG binding, else an importing         -- module will use the wrong calling convention-        --      (Trac #2844 was an example where this happened)+        --      (#2844 was an example where this happened)         -- NB1: we can't move the assertion further out without         --      blocking the "knot" tied in coreTopBindsToStg         -- NB2: the arity check is only needed for Ids with External@@ -384,11 +404,13 @@   -- We lower 'LitRubbish' to @()@ here, which is much easier than doing it in   -- a STG to Cmm pass.   = coreToStgExpr (Var unitDataConId)-coreToStgExpr (Var v)      = coreToStgApp Nothing v               [] []-coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId [] []+coreToStgExpr (Var v) = coreToStgApp v [] []+coreToStgExpr (Coercion _)+  -- See Note [Coercion tokens]+  = coreToStgApp coercionTokenId [] []  coreToStgExpr expr@(App _ _)-  = coreToStgApp Nothing f args ticks+  = coreToStgApp f args ticks   where     (f, args, ticks) = myCollectArgs expr @@ -502,18 +524,11 @@ -- Applications -- --------------------------------------------------------------------------- -coreToStgApp-         :: Maybe UpdateFlag            -- Just upd <=> this application is-                                        -- the rhs of a thunk binding-                                        --      x = [...] \upd [] -> the_app-                                        -- with specified update flag-        -> Id                           -- Function-        -> [CoreArg]                    -- Arguments-        -> [Tickish Id]                 -- Debug ticks-        -> CtsM StgExpr---coreToStgApp _ f args ticks = do+coreToStgApp :: Id            -- Function+             -> [CoreArg]     -- Arguments+             -> [Tickish Id]  -- Debug ticks+             -> CtsM StgExpr+coreToStgApp f args ticks = do     (args', ticks') <- coreToStgArgs args     how_bound <- lookupVarCts f @@ -552,7 +567,7 @@                  -- A regular foreign call.                 FCallId call     -> ASSERT( saturated )-                                    StgOpApp (StgFCallOp call (idUnique f)) args' res_ty+                                    StgOpApp (StgFCallOp call (idType f)) args' res_ty                  TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')                 _other           -> StgApp f args'@@ -576,7 +591,7 @@     (args', ts) <- coreToStgArgs args     return (args', ts) -coreToStgArgs (Coercion _ : args)  -- Coercion argument; replace with place holder+coreToStgArgs (Coercion _ : args) -- Coercion argument; See Note [Coercion tokens]   = do { (args', ts) <- coreToStgArgs args        ; return (StgVarArg coercionTokenId : args', ts) } @@ -605,16 +620,12 @@         -- This matters particularly when the function is a primop         -- or foreign call.         -- Wanted: a better solution than this hacky warning++    dflags <- getDynFlags     let-        arg_ty = exprType arg-        stg_arg_ty = stgArgType stg_arg-        bad_args = (isUnliftedType arg_ty && not (isUnliftedType stg_arg_ty))-                || (typePrimRep arg_ty /= typePrimRep stg_arg_ty)-        -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),-        -- and pass it to a function expecting an HValue (arg_ty).  This is ok because-        -- we can treat an unlifted value as lifted.  But the other way round-        -- we complain.-        -- We also want to check if a pointer is cast to a non-ptr etc+        arg_rep = typePrimRep (exprType arg)+        stg_arg_rep = typePrimRep (stgArgType stg_arg)+        bad_args = not (primRepsCompatible dflags arg_rep stg_arg_rep)      WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )      return (stg_arg : stg_args, ticks ++ aticks)@@ -644,8 +655,8 @@          -- Compute the new let-expression     let-        new_let | isJoinBind bind = StgLetNoEscape noExtSilent bind2 body2-                | otherwise       = StgLet noExtSilent bind2 body2+        new_let | isJoinBind bind = StgLetNoEscape noExtFieldSilent bind2 body2+                | otherwise       = StgLet noExtFieldSilent bind2 body2      return new_let   where@@ -688,7 +699,7 @@ mkTopStgRhs dflags this_mod ccs bndr rhs   | StgLam bndrs body <- rhs   = -- StgLam can't have empty arguments, so not CAF-    ( StgRhsClosure noExtSilent+    ( StgRhsClosure noExtFieldSilent                     dontCareCCS                     ReEntrant                     (toList bndrs) body@@ -704,19 +715,19 @@    -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].   | gopt Opt_AutoSccsOnIndividualCafs dflags-  = ( StgRhsClosure noExtSilent+  = ( StgRhsClosure noExtFieldSilent                     caf_ccs                     upd_flag [] rhs     , collectCC caf_cc caf_ccs ccs )    | otherwise-  = ( StgRhsClosure noExtSilent+  = ( StgRhsClosure noExtFieldSilent                     all_cafs_ccs                     upd_flag [] rhs     , ccs )    where-    (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs+    unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs      upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry              | otherwise                      = Updatable@@ -738,14 +749,14 @@ mkStgRhs :: Id -> StgExpr -> StgRhs mkStgRhs bndr rhs   | StgLam bndrs body <- rhs-  = StgRhsClosure noExtSilent+  = StgRhsClosure noExtFieldSilent                   currentCCS                   ReEntrant                   (toList bndrs) body    | isJoinId bndr -- must be a nullary join point   = ASSERT(idJoinArity bndr == 0)-    StgRhsClosure noExtSilent+    StgRhsClosure noExtFieldSilent                   currentCCS                   ReEntrant -- ignored for LNE                   [] rhs@@ -754,11 +765,11 @@   = StgRhsCon currentCCS con args    | otherwise-  = StgRhsClosure noExtSilent+  = StgRhsClosure noExtFieldSilent                   currentCCS                   upd_flag [] rhs   where-    (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs+    unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs      upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry              | otherwise                      = Updatable@@ -823,9 +834,11 @@ -- *down*.  newtype CtsM a = CtsM-    { unCtsM :: IdEnv HowBound+    { unCtsM :: DynFlags -- Needed for checking for bad coercions in coreToStgArgs+             -> IdEnv HowBound              -> a     }+    deriving (Functor)  data HowBound   = ImportBound         -- Used only as a response to lookupBinding; never@@ -859,8 +872,8 @@  -- The std monad functions: -initCts :: IdEnv HowBound -> CtsM a -> a-initCts env m = unCtsM m env+initCts :: DynFlags -> IdEnv HowBound -> CtsM a -> a+initCts dflags env m = unCtsM m dflags env   @@ -868,14 +881,11 @@ {-# INLINE returnCts #-}  returnCts :: a -> CtsM a-returnCts e = CtsM $ \_ -> e+returnCts e = CtsM $ \_ _ -> e  thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b-thenCts m k = CtsM $ \env-  -> unCtsM (k (unCtsM m env)) env--instance Functor CtsM where-    fmap = liftM+thenCts m k = CtsM $ \dflags env+  -> unCtsM (k (unCtsM m dflags env)) dflags env  instance Applicative CtsM where     pure = returnCts@@ -884,15 +894,18 @@ instance Monad CtsM where     (>>=)  = thenCts +instance HasDynFlags CtsM where+    getDynFlags = CtsM $ \dflags _ -> dflags+ -- Functions specific to this monad:  extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a extendVarEnvCts ids_w_howbound expr-   =    CtsM $   \env-   -> unCtsM expr (extendVarEnvList env ids_w_howbound)+   =    CtsM $   \dflags env+   -> unCtsM expr dflags (extendVarEnvList env ids_w_howbound)  lookupVarCts :: Id -> CtsM HowBound-lookupVarCts v = CtsM $ \env -> lookupBinding env v+lookupVarCts v = CtsM $ \_ env -> lookupBinding env v  lookupBinding :: IdEnv HowBound -> Id -> HowBound lookupBinding env v = case lookupVarEnv env v of
compiler/stgSyn/StgLint.hs view
@@ -32,7 +32,8 @@ basic properties listed above. -} -{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies,+  DeriveFunctor #-}  module StgLint ( lintStgTopBindings ) where @@ -258,6 +259,7 @@               -> Bag MsgDoc        -- Error messages so far               -> (a, Bag MsgDoc)   -- Result and error messages (if any)     }+    deriving (Functor)  data LintFlags = LintFlags { lf_unarised :: !Bool                              -- ^ have we run the unariser yet?@@ -292,9 +294,6 @@       Nothing   else       Just (vcat (punctuate blankLine (bagToList errs)))--instance Functor LintM where-      fmap = liftM  instance Applicative LintM where       pure a = LintM $ \_mod _lf _loc _scope errs -> (a, errs)
compiler/stgSyn/StgSubst.hs view
@@ -2,7 +2,7 @@  module StgSubst where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -72,7 +72,7 @@ extendInScope id (Subst in_scope env) = Subst (in_scope `extendInScopeSet` id) env  -- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the--- in-scope set is such that TyCORep Note [The substitution invariant]+-- in-scope set is such that TyCoSubst Note [The substitution invariant] -- holds after extending the substitution like this. extendSubst :: Id -> Id -> Subst -> Subst extendSubst id new_id (Subst in_scope env)
compiler/stgSyn/StgSyn.hs view
@@ -1,7 +1,8 @@ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -\section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation}+Shared term graph (STG) syntax for spineless-tagless code generation+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  This data type represents programs just before code generation (conversion to @Cmm@): basically, what we have is a stylised form of @CoreSyntax@, the style@@ -25,7 +26,7 @@         GenStgAlt, AltType(..),          StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape,-        NoExtSilent, noExtSilent,+        NoExtFieldSilent, noExtFieldSilent,         OutputablePass,          UpdateFlag(..), isUpdatable,@@ -50,13 +51,13 @@         topStgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity,         isDllConApp,         stgArgType,-        stripStgTicksTop,+        stripStgTicksTop, stripStgTicksTopE,         stgCaseBndrInScope,          pprStgBinding, pprGenStgTopBindings, pprStgTopBindings     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -67,7 +68,6 @@ import Data.List   ( intersperse ) import DataCon import DynFlags-import FastString import ForeignCall ( ForeignCall ) import Id import IdInfo      ( mayHaveCafRefs )@@ -76,13 +76,12 @@ import Module      ( Module ) import Outputable import Packages    ( isDllName )-import Platform+import GHC.Platform import PprCore     ( {- instances -} ) import PrimOp      ( PrimOp, PrimCall ) import TyCon       ( PrimRep(..), TyCon ) import Type        ( Type ) import RepType     ( typePrimRep1 )-import Unique      ( Unique ) import Util  import Data.List.NonEmpty ( NonEmpty, toList )@@ -90,14 +89,13 @@ {- ************************************************************************ *                                                                      *-\subsection{@GenStgBinding@}+GenStgBinding *                                                                      * ************************************************************************ -As usual, expressions are interesting; other things are boring. Here-are the boring things [except note the @GenStgRhs@], parameterised-with respect to binder and occurrence information (just as in-@CoreSyn@):+As usual, expressions are interesting; other things are boring. Here are the+boring things (except note the @GenStgRhs@), parameterised with respect to+binder and occurrence information (just as in @CoreSyn@): -}  -- | A top-level binding.@@ -113,7 +111,7 @@ {- ************************************************************************ *                                                                      *-\subsection{@StgArg@}+StgArg *                                                                      * ************************************************************************ -}@@ -122,8 +120,8 @@   = StgVarArg  Id   | StgLitArg  Literal --- | Does this constructor application refer to--- anything in a different *Windows* DLL?+-- | Does this constructor application refer to anything in a different+-- *Windows* DLL? -- If so, we can't allocate it statically isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool isDllConApp dflags this_mod con args@@ -138,17 +136,22 @@                              && isDllName dflags this_mod (idName v)     is_dll_arg _             = False --- True of machine addresses; these are the things that don't--- work across DLLs. The key point here is that VoidRep comes--- out False, so that a top level nullary GADT constructor is--- False for isDllConApp+-- True of machine addresses; these are the things that don't work across DLLs.+-- The key point here is that VoidRep comes out False, so that a top level+-- nullary GADT constructor is False for isDllConApp+-- --    data T a where --      T1 :: T Int+-- -- gives+-- --    T1 :: forall a. (a~Int) -> T a+-- -- and hence the top-level binding+-- --    $WT1 :: T Int --    $WT1 = T1 Int (Coercion (Refl Int))+-- -- The coercion argument here gets VoidRep isAddrRep :: PrimRep -> Bool isAddrRep AddrRep     = True@@ -164,12 +167,18 @@ stgArgType (StgLitArg lit) = literalType lit  --- | Strip ticks of a given type from an STG expression+-- | Strip ticks of a given type from an STG expression. stripStgTicksTop :: (Tickish Id -> Bool) -> GenStgExpr p -> ([Tickish Id], GenStgExpr p) stripStgTicksTop p = go []    where go ts (StgTick t e) | p t = go (t:ts) e          go ts other               = (reverse ts, other) +-- | Strip ticks of a given type from an STG expression returning only the expression.+stripStgTicksTopE :: (Tickish Id -> Bool) -> GenStgExpr p -> GenStgExpr p+stripStgTicksTopE p = go+   where go (StgTick t e) | p t = go e+         go other               = other+ -- | Given an alt type and whether the program is unarised, return whether the -- case binder is in scope. --@@ -186,26 +195,25 @@ {- ************************************************************************ *                                                                      *-\subsection{STG expressions}+STG expressions *                                                                      * ************************************************************************ -The @GenStgExpr@ data type is parameterised on binder and occurrence-info, as before.+The @GenStgExpr@ data type is parameterised on binder and occurrence info, as+before.  ************************************************************************ *                                                                      *-\subsubsection{@GenStgExpr@ application}+GenStgExpr *                                                                      * ************************************************************************ -An application is of a function to a list of atoms [not expressions].-Operationally, we want to push the arguments on the stack and call the-function. (If the arguments were expressions, we would have to build-their closures first.)+An application is of a function to a list of atoms (not expressions).+Operationally, we want to push the arguments on the stack and call the function.+(If the arguments were expressions, we would have to build their closures+first.) -There is no constructor for a lone variable; it would appear as-@StgApp var []@.+There is no constructor for a lone variable; it would appear as @StgApp var []@. -}  data GenStgExpr pass@@ -216,18 +224,18 @@ {- ************************************************************************ *                                                                      *-\subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications}+StgConApp and StgPrimApp --- saturated applications *                                                                      * ************************************************************************ -There are specialised forms of application, for constructors,-primitives, and literals.+There are specialised forms of application, for constructors, primitives, and+literals. -}    | StgLit      Literal          -- StgConApp is vital for returning unboxed tuples or sums-        -- which can't be let-bound first+        -- which can't be let-bound   | StgConApp   DataCon                 [StgArg] -- Saturated                 [Type]   -- See Note [Types in StgConApp] in UnariseStg@@ -241,13 +249,13 @@ {- ************************************************************************ *                                                                      *-\subsubsection{@StgLam@}+StgLam *                                                                      * ************************************************************************ -StgLam is used *only* during CoreToStg's work. Before CoreToStg has-finished it encodes (\x -> e) as (let f = \x -> e in f)-TODO: Encode this via an extension to GenStgExpr à la TTG.+StgLam is used *only* during CoreToStg's work. Before CoreToStg has finished it+encodes (\x -> e) as (let f = \x -> e in f) TODO: Encode this via an extension+to GenStgExpr à la TTG. -}    | StgLam@@ -257,7 +265,7 @@ {- ************************************************************************ *                                                                      *-\subsubsection{@GenStgExpr@: case-expressions}+GenStgExpr: case-expressions *                                                                      * ************************************************************************ @@ -275,94 +283,75 @@ {- ************************************************************************ *                                                                      *-\subsubsection{@GenStgExpr@: @let(rec)@-expressions}+GenStgExpr: let(rec)-expressions *                                                                      * ************************************************************************ -The various forms of let(rec)-expression encode most of the-interesting things we want to do.-\begin{enumerate}-\item-\begin{verbatim}-let-closure x = [free-vars] [args] expr-in e-\end{verbatim}-is equivalent to-\begin{verbatim}-let x = (\free-vars -> \args -> expr) free-vars-\end{verbatim}-\tr{args} may be empty (and is for most closures).  It isn't under-circumstances like this:-\begin{verbatim}-let x = (\y -> y+z)-\end{verbatim}-This gets mangled to-\begin{verbatim}-let-closure x = [z] [y] (y+z)-\end{verbatim}-The idea is that we compile code for @(y+z)@ in an environment in which-@z@ is bound to an offset from \tr{Node}, and @y@ is bound to an-offset from the stack pointer.+The various forms of let(rec)-expression encode most of the interesting things+we want to do. -(A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)+-   let-closure x = [free-vars] [args] expr in e -\item-\begin{verbatim}-let-constructor x = Constructor [args]-in e-\end{verbatim}+  is equivalent to -(A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)+    let x = (\free-vars -> \args -> expr) free-vars -\item-Letrec-expressions are essentially the same deal as-let-closure/let-constructor, so we use a common structure and-distinguish between them with an @is_recursive@ boolean flag.+  @args@ may be empty (and is for most closures). It isn't under circumstances+  like this: -\item-\begin{verbatim}-let-unboxed u = an arbitrary arithmetic expression in unboxed values-in e-\end{verbatim}-All the stuff on the RHS must be fully evaluated.-No function calls either!+    let x = (\y -> y+z) -(We've backed away from this toward case-expressions with-suitably-magical alts ...)+  This gets mangled to -\item-~[Advanced stuff here! Not to start with, but makes pattern matching-generate more efficient code.]+    let-closure x = [z] [y] (y+z) -\begin{verbatim}-let-escapes-not fail = expr-in e'-\end{verbatim}-Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,-or pass it to another function. All @e'@ will ever do is tail-call @fail@.-Rather than build a closure for @fail@, all we need do is to record the stack-level at the moment of the @let-escapes-not@; then entering @fail@ is just-a matter of adjusting the stack pointer back down to that point and entering-the code for it.+  The idea is that we compile code for @(y+z)@ in an environment in which @z@ is+  bound to an offset from Node, and `y` is bound to an offset from the stack+  pointer. -Another example:-\begin{verbatim}-f x y = let z = huge-expression in-        if y==1 then z else-        if y==2 then z else-        1-\end{verbatim}+  (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.) -(A let-escapes-not is an @StgLetNoEscape@.)+-   let-constructor x = Constructor [args] in e -\item-We may eventually want:-\begin{verbatim}-let-literal x = Literal-in e-\end{verbatim}-\end{enumerate}+  (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.) +- Letrec-expressions are essentially the same deal as let-closure/+  let-constructor, so we use a common structure and distinguish between them+  with an @is_recursive@ boolean flag.++-   let-unboxed u = <an arbitrary arithmetic expression in unboxed values> in e++  All the stuff on the RHS must be fully evaluated. No function calls either!++  (We've backed away from this toward case-expressions with suitably-magical+  alts ...)++- Advanced stuff here! Not to start with, but makes pattern matching generate+  more efficient code.++    let-escapes-not fail = expr+    in e'++  Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,+  or pass it to another function. All @e'@ will ever do is tail-call @fail@.+  Rather than build a closure for @fail@, all we need do is to record the stack+  level at the moment of the @let-escapes-not@; then entering @fail@ is just a+  matter of adjusting the stack pointer back down to that point and entering the+  code for it.++  Another example:++    f x y = let z = huge-expression in+            if y==1 then z else+            if y==2 then z else+            1++  (A let-escapes-not is an @StgLetNoEscape@.)++- We may eventually want:++    let-literal x = Literal in e+ And so the code for let(rec)-things: -} @@ -377,11 +366,11 @@         (GenStgExpr pass)       -- body  {--%************************************************************************-%*                                                                      *-\subsubsection{@GenStgExpr@: @hpc@, @scc@ and other debug annotations}-%*                                                                      *-%************************************************************************+*************************************************************************+*                                                                      *+GenStgExpr: hpc, scc and other debug annotations+*                                                                      *+*************************************************************************  Finally for @hpc@ expressions we introduce a new STG construct. -}@@ -395,12 +384,12 @@ {- ************************************************************************ *                                                                      *-\subsection{STG right-hand sides}+STG right-hand sides *                                                                      * ************************************************************************ -Here's the rest of the interesting stuff for @StgLet@s; the first-flavour is for closures:+Here's the rest of the interesting stuff for @StgLet@s; the first flavour is for+closures: -}  data GenStgRhs pass@@ -415,18 +404,19 @@  {- An example may be in order.  Consider:-\begin{verbatim}-let t = \x -> \y -> ... x ... y ... p ... q in e-\end{verbatim}++  let t = \x -> \y -> ... x ... y ... p ... q in e+ Pulling out the free vars and stylising somewhat, we get the equivalent:-\begin{verbatim}-let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q-\end{verbatim}-Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are-offsets from @Node@ into the closure, and the code ptr for the closure-will be exactly that in parentheses above. -The second flavour of right-hand-side is for constructors (simple but important):+  let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q++Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are offsets from+@Node@ into the closure, and the code ptr for the closure will be exactly that+in parentheses above.++The second flavour of right-hand-side is for constructors (simple but+important): -}    | StgRhsCon@@ -445,20 +435,20 @@   | LiftLams   | CodeGen --- | Like 'HsExpression.NoExt', but with an 'Outputable' instance that returns--- 'empty'.-data NoExtSilent = NoExtSilent+-- | Like 'GHC.Hs.Extension.NoExtField', but with an 'Outputable' instance that+-- returns 'empty'.+data NoExtFieldSilent = NoExtFieldSilent   deriving (Data, Eq, Ord) -instance Outputable NoExtSilent where+instance Outputable NoExtFieldSilent where   ppr _ = empty  -- | Used when constructing a term with an unused extension point that should -- not appear in pretty-printed output at all.-noExtSilent :: NoExtSilent-noExtSilent = NoExtSilent--- TODO: Maybe move this to HsExtensions? I'm not sure about the implications--- on build time...+noExtFieldSilent :: NoExtFieldSilent+noExtFieldSilent = NoExtFieldSilent+-- TODO: Maybe move this to GHC.Hs.Extension? I'm not sure about the+-- implications on build time...  -- TODO: Do we really want to the extension point type families to have a closed -- domain?@@ -467,17 +457,17 @@ type instance BinderP 'CodeGen = Id  type family XRhsClosure (pass :: StgPass)-type instance XRhsClosure 'Vanilla = NoExtSilent+type instance XRhsClosure 'Vanilla = NoExtFieldSilent -- | Code gen needs to track non-global free vars type instance XRhsClosure 'CodeGen = DIdSet  type family XLet (pass :: StgPass)-type instance XLet 'Vanilla = NoExtSilent-type instance XLet 'CodeGen = NoExtSilent+type instance XLet 'Vanilla = NoExtFieldSilent+type instance XLet 'CodeGen = NoExtFieldSilent  type family XLetNoEscape (pass :: StgPass)-type instance XLetNoEscape 'Vanilla = NoExtSilent-type instance XLetNoEscape 'CodeGen = NoExtSilent+type instance XLetNoEscape 'Vanilla = NoExtFieldSilent+type instance XLetNoEscape 'CodeGen = NoExtFieldSilent  stgRhsArity :: StgRhs -> Int stgRhsArity (StgRhsClosure _ _ _ bndrs _)@@ -564,20 +554,19 @@ {- ************************************************************************ *                                                                      *-\subsection[Stg-case-alternatives]{STG case alternatives}+STG case alternatives *                                                                      * ************************************************************************  Very like in @CoreSyntax@ (except no type-world stuff). -The type constructor is guaranteed not to be abstract; that is, we can-see its representation. This is important because the code generator-uses it to determine return conventions etc. But it's not trivial-where there's a module loop involved, because some versions of a type-constructor might not have all the constructors visible. So-mkStgAlgAlts (in CoreToStg) ensures that it gets the TyCon from the-constructors or literals (which are guaranteed to have the Real McCoy)-rather than from the scrutinee type.+The type constructor is guaranteed not to be abstract; that is, we can see its+representation. This is important because the code generator uses it to+determine return conventions etc. But it's not trivial where there's a module+loop involved, because some versions of a type constructor might not have all+the constructors visible. So mkStgAlgAlts (in CoreToStg) ensures that it gets+the TyCon from the constructors or literals (which are guaranteed to have the+Real McCoy) rather than from the scrutinee type. -}  type GenStgAlt pass@@ -596,7 +585,7 @@ {- ************************************************************************ *                                                                      *-\subsection[Stg]{The Plain STG parameterisation}+The Plain STG parameterisation *                                                                      * ************************************************************************ @@ -643,17 +632,16 @@  ************************************************************************ *                                                                      *-\subsubsection[UpdateFlag-datatype]{@UpdateFlag@}+UpdateFlag *                                                                      * ************************************************************************  This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module. -A @ReEntrant@ closure may be entered multiple times, but should not be-updated or blackholed. An @Updatable@ closure should be updated after-evaluation (and may be blackholed during evaluation). A @SingleEntry@-closure will only be entered once, and so need not be updated but may-safely be blackholed.+A @ReEntrant@ closure may be entered multiple times, but should not be updated+or blackholed. An @Updatable@ closure should be updated after evaluation (and+may be blackholed during evaluation). A @SingleEntry@ closure will only be+entered once, and so need not be updated but may safely be blackholed. -}  data UpdateFlag = ReEntrant | Updatable | SingleEntry@@ -672,13 +660,12 @@ {- ************************************************************************ *                                                                      *-\subsubsection{StgOp}+StgOp *                                                                      * ************************************************************************ -An StgOp allows us to group together PrimOps and ForeignCalls.-It's quite useful to move these around together, notably-in StgOpApp and COpStmt.+An StgOp allows us to group together PrimOps and ForeignCalls. It's quite useful+to move these around together, notably in StgOpApp and COpStmt. -}  data StgOp@@ -686,20 +673,21 @@    | StgPrimCallOp PrimCall -  | StgFCallOp ForeignCall Unique-        -- The Unique is occasionally needed by the C pretty-printer-        -- (which lacks a unique supply), notably when generating a-        -- typedef for foreign-export-dynamic+  | StgFCallOp ForeignCall Type+        -- The Type, which is obtained from the foreign import declaration+        -- itself, is needed by the stg-to-cmm pass to determine the offset to+        -- apply to unlifted boxed arguments in GHC.StgToCmm.Foreign. See Note+        -- [Unlifted boxed arguments to foreign calls]  {- ************************************************************************ *                                                                      *-\subsection[Stg-pretty-printing]{Pretty-printing}+Pretty-printing *                                                                      * ************************************************************************ -Robin Popplestone asked for semi-colon separators on STG binds; here's-hoping he likes terminators instead...  Ditto for case alternatives.+Robin Popplestone asked for semi-colon separators on STG binds; here's hoping he+likes terminators instead...  Ditto for case alternatives. -}  type OutputablePass pass =@@ -726,7 +714,7 @@  pprGenStgBinding (StgRec pairs)   = vcat [ text "Rec {"-         , vcat (map ppr_bind pairs)+         , vcat (intersperse blankLine (map ppr_bind pairs))          , text "end Rec }" ]   where     ppr_bind (bndr, expr)@@ -831,19 +819,32 @@     else sep [ ppr tickish, pprStgExpr expr ]  +-- Don't indent for a single case alternative.+pprStgExpr (StgCase expr bndr alt_type [alt])+  = sep [sep [text "case",+           nest 4 (hsep [pprStgExpr expr,+             whenPprDebug (dcolon <+> ppr alt_type)]),+           text "of", pprBndr CaseBind bndr, char '{'],+           pprStgAlt False alt,+           char '}']+ pprStgExpr (StgCase expr bndr alt_type alts)   = sep [sep [text "case",            nest 4 (hsep [pprStgExpr expr,              whenPprDebug (dcolon <+> ppr alt_type)]),            text "of", pprBndr CaseBind bndr, char '{'],-           nest 2 (vcat (map pprStgAlt alts)),+           nest 2 (vcat (map (pprStgAlt True) alts)),            char '}'] -pprStgAlt :: OutputablePass pass => GenStgAlt pass -> SDoc-pprStgAlt (con, params, expr)-  = hang (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])-         4 (ppr expr <> semi) +pprStgAlt :: OutputablePass pass => Bool -> GenStgAlt pass -> SDoc+pprStgAlt indent (con, params, expr)+  | indent    = hang altPattern 4 (ppr expr <> semi)+  | otherwise = sep [altPattern, ppr expr <> semi]+    where+      altPattern = (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])++ pprStgOp :: StgOp -> SDoc pprStgOp (StgPrimOp  op)   = ppr op pprStgOp (StgPrimCallOp op)= ppr op@@ -857,15 +858,6 @@  pprStgRhs :: OutputablePass pass => GenStgRhs pass -> SDoc --- special case-pprStgRhs (StgRhsClosure ext cc upd_flag [{-no args-}] (StgApp func []))-  = sdocWithDynFlags $ \dflags ->-    hsep [ ppr cc,-           if not $ gopt Opt_SuppressStgExts dflags-             then ppr ext else empty,-           text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ]---- general case pprStgRhs (StgRhsClosure ext cc upd_flag args body)   = sdocWithDynFlags $ \dflags ->     hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty,
compiler/stranal/DmdAnal.hs view
@@ -11,7 +11,7 @@  module DmdAnal ( dmdAnalProgram ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -23,7 +23,7 @@ import Outputable import VarEnv import BasicTypes-import Data.List+import Data.List        ( mapAccumL, sortBy ) import DataCon import Id import CoreUtils        ( exprIsHNF, exprType, exprIsTrivial, exprOkForSpeculation )@@ -93,7 +93,7 @@ no references holding on to the input Core program.  This makes a ~30% reduction in peak memory usage when compiling-DynFlags (cf Trac #9675 and #13426).+DynFlags (cf #9675 and #13426).  This is particularly important when we are doing late demand analysis, since we don't do a seqBinds at any point thereafter. Hence code@@ -189,7 +189,7 @@ dmdAnal' env dmd (App fun arg)   = -- This case handles value arguments (type args handled above)     -- Crucially, coercions /are/ handled here, because they are-    -- value arguments (Trac #10288)+    -- value arguments (#10288)     let         call_dmd          = mkCallDmd dmd         (fun_ty, fun')    = dmdAnal env call_dmd fun@@ -206,7 +206,6 @@ --         , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])     (res_ty `bothDmdType` arg_ty, App fun' arg') --- this is an anonymous lambda, since @dmdAnalRhsLetDown@ uses @collectBinders@ dmdAnal' env dmd (Lam var body)   | isTyVar var   = let@@ -286,10 +285,7 @@ -- This is used for a non-recursive local let without manifest lambdas. -- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”. dmdAnal' env dmd (Let (NonRec id rhs) body)-  | useLetUp id rhs-  , Nothing <- unpackTrivial rhs-      -- dmdAnalRhsLetDown treats trivial right hand sides specially-      -- so if we have a trival right hand side, fall through to that.+  | useLetUp id   = (final_ty, Let (NonRec id' rhs') body')   where     (body_ty, body')   = dmdAnal env dmd body@@ -376,7 +372,7 @@         other      -> return () So the 'y' isn't necessarily going to be evaluated -A more complete example (Trac #148, #1592) where this shows up is:+A more complete example (#148, #1592) where this shows up is:      do { let len = <expensive> ;         ; when (...) (exitWith ExitSuccess)         ; print len }@@ -582,25 +578,6 @@  -} --- Trivial RHS--- See Note [Demand analysis for trivial right-hand sides]-dmdAnalTrivialRhs ::-    AnalEnv -> Id -> CoreExpr -> Var ->-    (DmdEnv, Id, CoreExpr)-dmdAnalTrivialRhs env id rhs fn-  = (fn_fv, set_idStrictness env id fn_str, rhs)-  where-    fn_str = getStrictness env fn-    fn_fv | isLocalId fn = unitVarEnv fn topDmd-          | otherwise    = emptyDmdEnv-    -- Note [Remember to demand the function itself]-    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-    -- fn_fv: don't forget to produce a demand for fn itself-    -- Lacking this caused Trac #9128-    -- The demand is very conservative (topDmd), but that doesn't-    -- matter; trivial bindings are usually inlined, so it only-    -- kicks in for top-level bindings and NOINLINE bindings- -- Let bindings can be processed in two ways: -- Down (RHS before body) or Up (body before RHS). -- dmdAnalRhsLetDown implements the Down variant:@@ -621,28 +598,23 @@ -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well. dmdAnalRhsLetDown top_lvl rec_flag env let_dmd id rhs-  | Just fn <- unpackTrivial rhs   -- See Note [Demand analysis for trivial right-hand sides]-  = dmdAnalTrivialRhs env id rhs fn--  | otherwise-  = (lazy_fv, id', mkLams bndrs' body')+  = (lazy_fv, id', rhs')   where-    (bndrs, body, body_dmd)-       = case isJoinId_maybe id of-           Just join_arity  -- See Note [Demand analysis for join points]-                   | (bndrs, body) <- collectNBinders join_arity rhs-                   -> (bndrs, body, let_dmd)--           Nothing | (bndrs, body) <- collectBinders rhs-                   -> (bndrs, body, mkBodyDmd env body)--    env_body         = foldl' extendSigsWithLam env bndrs-    (body_ty, body') = dmdAnal env_body body_dmd body-    body_ty'         = removeDmdTyArgs body_ty -- zap possible deep CPR info-    (DmdType rhs_fv rhs_dmds rhs_res, bndrs')-                     = annotateLamBndrs env (isDFunId id) body_ty' bndrs-    sig_ty           = mkStrictSig (mkDmdType sig_fv rhs_dmds rhs_res')-    id'              = set_idStrictness env id sig_ty+    rhs_arity      = idArity id+    rhs_dmd+      -- See Note [Demand analysis for join points]+      -- See Note [Invariants on join points] invariant 2b, in CoreSyn+      --     rhs_arity matches the join arity of the join point+      | isJoinId id+      = mkCallDmds rhs_arity let_dmd+      | otherwise+      -- NB: rhs_arity+      -- See Note [Demand signatures are computed for a threshold demand based on idArity]+      = mkRhsDmd env rhs_arity rhs+    (DmdType rhs_fv rhs_dmds rhs_res, rhs')+                   = dmdAnal env rhs_dmd rhs+    sig            = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_res')+    id'            = set_idStrictness env id sig         -- See Note [NOINLINE and strictness]  @@ -666,36 +638,63 @@        || not (isStrictDmd (idDemandInfo id) || ae_virgin env)           -- See Note [Optimistic CPR in the "virgin" case] -mkBodyDmd :: AnalEnv -> CoreExpr -> CleanDemand--- See Note [Product demands for function body]-mkBodyDmd env body-  = case deepSplitProductType_maybe (ae_fam_envs env) (exprType body) of-       Nothing            -> cleanEvalDmd-       Just (dc, _, _, _) -> cleanEvalProdDmd (dataConRepArity dc)--unpackTrivial :: CoreExpr -> Maybe Id--- Returns (Just v) if the arg is really equal to v, modulo--- casts, type applications etc--- See Note [Demand analysis for trivial right-hand sides]-unpackTrivial (Var v)                 = Just v-unpackTrivial (Cast e _)              = unpackTrivial e-unpackTrivial (Lam v e) | isTyVar v   = unpackTrivial e-unpackTrivial (App e a) | isTypeArg a = unpackTrivial e-unpackTrivial _                       = Nothing+-- | @mkRhsDmd env rhs_arity rhs@ creates a 'CleanDemand' for+-- unleashing on the given function's @rhs@, by creating a call demand of+-- @rhs_arity@ with a body demand appropriate for possible product types.+-- See Note [Product demands for function body].+-- For example, a call of the form @mkRhsDmd _ 2 (\x y -> (x, y))@ returns a+-- clean usage demand of @C1(C1(U(U,U)))@.+mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> CleanDemand+mkRhsDmd env rhs_arity rhs =+  case peelTsFuns rhs_arity (findTypeShape (ae_fam_envs env) (exprType rhs)) of+    Just (TsProd tss) -> mkCallDmds rhs_arity (cleanEvalProdDmd (length tss))+    _                 -> mkCallDmds rhs_arity cleanEvalDmd --- | If given the RHS of a let-binding, this 'useLetUp' determines--- whether we should process the binding up (body before rhs) or--- down (rhs before body).+-- | If given the let-bound 'Id', 'useLetUp' determines whether we should+-- process the binding up (body before rhs) or down (rhs before body). ----- We use LetDown if there is a chance to get a useful strictness signature.--- This is the case when there are manifest value lambdas or the binding is a--- join point (hence always acts like a function, not a value).-useLetUp :: Var -> CoreExpr -> Bool-useLetUp f _         | isJoinId f = False-useLetUp f (Lam v e) | isTyVar v  = useLetUp f e-useLetUp _ (Lam _ _)              = False-useLetUp _ _                      = True-+-- We use LetDown if there is a chance to get a useful strictness signature to+-- unleash at call sites. LetDown is generally more precise than LetUp if we can+-- correctly guess how it will be used in the body, that is, for which incoming+-- demand the strictness signature should be computed, which allows us to+-- unleash higher-order demands on arguments at call sites. This is mostly the+-- case when+--+--   * The binding takes any arguments before performing meaningful work (cf.+--     'idArity'), in which case we are interested to see how it uses them.+--   * The binding is a join point, hence acting like a function, not a value.+--     As a big plus, we know *precisely* how it will be used in the body; since+--     it's always tail-called, we can directly unleash the incoming demand of+--     the let binding on its RHS when computing a strictness signature. See+--     [Demand analysis for join points].+--+-- Thus, if the binding is not a join point and its arity is 0, we have a thunk+-- and use LetUp, implying that we have no usable demand signature available+-- when we analyse the let body.+--+-- Since thunk evaluation is memoised, we want to unleash its 'DmdEnv' of free+-- vars at most once, regardless of how many times it was forced in the body.+-- This makes a real difference wrt. usage demands. The other reason is being+-- able to unleash a more precise product demand on its RHS once we know how the+-- thunk was used in the let body.+--+-- Characteristic examples, always assuming a single evaluation:+--+--   * @let x = 2*y in x + x@ => LetUp. Compared to LetDown, we find out that+--     the expression uses @y@ at most once.+--   * @let x = (a,b) in fst x@ => LetUp. Compared to LetDown, we find out that+--     @b@ is absent.+--   * @let f x = x*2 in f y@ => LetDown. Compared to LetUp, we find out that+--     the expression uses @y@ strictly, because we have @f@'s demand signature+--     available at the call site.+--   * @join exit = 2*y in if a then exit else if b then exit else 3*y@ =>+--     LetDown. Compared to LetUp, we find out that the expression uses @y@+--     strictly, because we can unleash @exit@'s signature at each call site.+--   * For a more convincing example with join points, see Note [Demand analysis+--     for join points].+--+useLetUp :: Var -> Bool+useLetUp f = idArity f == 0 && not (isJoinId f)  {- Note [Demand analysis for join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -726,24 +725,158 @@ analyse its body with the demand from the entire join-binding (written let_dmd here). -Another win for join points!  Trac #13543.+Another win for join points!  #13543. +However, note that the strictness signature for a join point can+look a little puzzling.  E.g.++    (join j x = \y. error "urk")+    (in case v of              )+    (     A -> j 3             )  x+    (     B -> j 4             )+    (     C -> \y. blah        )++The entire thing is in a C(S) context, so j's strictness signature+will be    [A]b+meaning one absent argument, returns bottom.  That seems odd because+there's a \y inside.  But it's right because when consumed in a C(1)+context the RHS of the join point is indeed bottom.++Note [Demand signatures are computed for a threshold demand based on idArity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We compute demand signatures assuming idArity incoming arguments to approximate+behavior for when we have a call site with at least that many arguments. idArity+is /at least/ the number of manifest lambdas, but might be higher for PAPs and+trivial RHS (see Note [Demand analysis for trivial right-hand sides]).++Because idArity of a function varies independently of its cardinality properties+(cf. Note [idArity varies independently of dmdTypeDepth]), we implicitly encode+the arity for when a demand signature is sound to unleash in its 'dmdTypeDepth'+(cf. Note [Understanding DmdType and StrictSig] in Demand). It is unsound to+unleash a demand signature when the incoming number of arguments is less than+that. See Note [What are demand signatures?] for more details on soundness.++Why idArity arguments? Because that's a conservative estimate of how many+arguments we must feed a function before it does anything interesting with them.+Also it elegantly subsumes the trivial RHS and PAP case.++There might be functions for which we might want to analyse for more incoming+arguments than idArity. Example:++  f x =+    if expensive+      then \y -> ... y ...+      else \y -> ... y ...++We'd analyse `f` under a unary call demand C(S), corresponding to idArity+being 1. That's enough to look under the manifest lambda and find out how a+unary call would use `x`, but not enough to look into the lambdas in the if+branches.++On the other hand, if we analysed for call demand C(C(S)), we'd get useful+strictness info for `y` (and more precise info on `x`) and possibly CPR+information, but++  * We would no longer be able to unleash the signature at unary call sites+  * Performing the worker/wrapper split based on this information would be+    implicitly eta-expanding `f`, playing fast and loose with divergence and+    even being unsound in the presence of newtypes, so we refrain from doing so.+    Also see Note [Don't eta expand in w/w] in WorkWrap.++Since we only compute one signature, we do so for arity 1. Computing multiple+signatures for different arities (i.e., polyvariance) would be entirely+possible, if it weren't for the additional runtime and implementation+complexity.++Note [idArity varies independently of dmdTypeDepth]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to check in CoreLint that dmdTypeDepth <= idArity for a let-bound+identifier. But that means we would have to zap demand signatures every time we+reset or decrease arity. That's an unnecessary dependency, because++  * The demand signature captures a semantic property that is independent of+    what the binding's current arity is+  * idArity is analysis information itself, thus volatile+  * We already *have* dmdTypeDepth, wo why not just use it to encode the+    threshold for when to unleash the signature+    (cf. Note [Understanding DmdType and StrictSig] in Demand)++Consider the following expression, for example:++    (let go x y = `x` seq ... in go) |> co++`go` might have a strictness signature of `<S><L>`. The simplifier will identify+`go` as a nullary join point through `joinPointBinding_maybe` and float the+coercion into the binding, leading to an arity decrease:++    join go = (\x y -> `x` seq ...) |> co in go++With the CoreLint check, we would have to zap `go`'s perfectly viable strictness+signature.++Note [What are demand signatures?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Demand analysis interprets expressions in the abstract domain of demand+transformers. Given an incoming demand we put an expression under, its abstract+transformer gives us back a demand type denoting how other things (like+arguments and free vars) were used when the expression was evaluated.+Here's an example:++  f x y =+    if x + expensive+      then \z -> z + y * ...+      else \z -> z * ...++The abstract transformer (let's call it F_e) of the if expression (let's call it+e) would transform an incoming head demand <S,HU> into a demand type like+{x-><S,1*U>,y-><L,U>}<L,U>. In pictures:++     Demand ---F_e---> DmdType+     <S,HU>            {x-><S,1*U>,y-><L,U>}<L,U>++Let's assume that the demand transformers we compute for an expression are+correct wrt. to some concrete semantics for Core. How do demand signatures fit+in? They are strange beasts, given that they come with strict rules when to+it's sound to unleash them.++Fortunately, we can formalise the rules with Galois connections. Consider+f's strictness signature, {}<S,1*U><L,U>. It's a single-point approximation of+the actual abstract transformer of f's RHS for arity 2. So, what happens is that+we abstract *once more* from the abstract domain we already are in, replacing+the incoming Demand by a simple lattice with two elements denoting incoming+arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom+element). Here's the diagram:++     A_2 -----f_f----> DmdType+      ^                   |+      | α               γ |+      |                   v+     Demand ---F_f---> DmdType++With+  α(C1(C1(_))) = >=2 -- example for usage demands, but similar for strictness+  α(_)         =  <2+  γ(ty)        =  ty+and F_f being the abstract transformer of f's RHS and f_f being the abstracted+abstract transformer computable from our demand signature simply by++  f_f(>=2) = {}<S,1*U><L,U>+  f_f(<2)  = postProcessUnsat {}<S,1*U><L,U>++where postProcessUnsat makes a proper top element out of the given demand type.+ Note [Demand analysis for trivial right-hand sides] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider-        foo = plusInt |> co+    foo = plusInt |> co where plusInt is an arity-2 function with known strictness.  Clearly we want plusInt's strictness to propagate to foo!  But because it has no manifest lambdas, it won't do so automatically, and indeed 'co' might-have type (Int->Int->Int) ~ T, so we *can't* eta-expand.  So we have a-special case for right-hand sides that are "trivial", namely variables,-casts, type applications, and the like.+have type (Int->Int->Int) ~ T. -Note that this can mean that 'foo' has an arity that is smaller than that-indicated by its demand info.  e.g. if co :: (Int->Int->Int) ~ T, then-foo's arity will be zero (see Note [exprArity invariant] in CoreArity),-but its demand signature will be that of plusInt. A small example is the-test case of Trac #8963.+Fortunately, CoreArity gives 'foo' arity 2, which is enough for LetDown to+forward plusInt's demand signature, and all is well (see Note [Newtype arity] in+CoreArity)! A small example is the test case NewtypeArity.   Note [Product demands for function body]@@ -841,13 +974,6 @@   where     (dmd_ty', dmd) = findBndrDmd env False dmd_ty var -annotateLamBndrs :: AnalEnv -> DFunFlag -> DmdType -> [Var] -> (DmdType, [Var])-annotateLamBndrs env args_of_dfun ty bndrs = mapAccumR annotate ty bndrs-  where-    annotate dmd_ty bndr-      | isId bndr = annotateLamIdBndr env args_of_dfun dmd_ty bndr-      | otherwise = (dmd_ty, bndr)- annotateLamIdBndr :: AnalEnv                   -> DFunFlag   -- is this lambda at the top of the RHS of a dfun?                   -> DmdType    -- Demand type of body@@ -1160,12 +1286,6 @@ lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag) lookupSigEnv env id = lookupVarEnv (ae_sigs env) id -getStrictness :: AnalEnv -> Id -> StrictSig-getStrictness env fn-  | isGlobalId fn                        = idStrictness fn-  | Just (sig, _) <- lookupSigEnv env fn = sig-  | otherwise                            = nopSig- nonVirgin :: AnalEnv -> AnalEnv nonVirgin env = env { ae_virgin = False } @@ -1304,7 +1424,7 @@    Slightly ad-hoc, because even if the scrutinee *is* a variable it    might not be a onre of the arguments to the original function, or a    sub-component thereof.  But it's simple, and nothing terrible-   happens if we get it wrong.  e.g. Trac #10694.+   happens if we get it wrong.  e.g. #10694.   Note [Initial CPR for strict binders]
compiler/stranal/WorkWrap.hs view
@@ -9,6 +9,7 @@  import GhcPrelude +import CoreArity        ( manifestArity ) import CoreSyn import CoreUnfold       ( certainlyWillInline, mkWwInlineRule, mkWorkerUnfolding ) import CoreUtils        ( exprType, exprIsHNF )@@ -27,7 +28,7 @@ import FamInstEnv import MonadUtils -#include "GhclibHsVersions.h"+#include "HsVersions.h"  {- We take Core bindings whose binders have:@@ -185,7 +186,7 @@ one! So the function would no longer be INLNABLE, and in particular will not be specialised at call sites in other modules. -This comes in practice (Trac #6056).+This comes in practice (#6056).  Solution: do the w/w for strictness analysis, but transfer the Stable unfolding to the *worker*.  So we will get something like this:@@ -240,8 +241,39 @@ Solution: do worker/wrapper even on NOINLINE things; but move the NOINLINE pragma to the worker. -(See Trac #13143 for a real-world example.)+(See #13143 for a real-world example.) +It is crucial that we do this for *all* NOINLINE functions. #10069+demonstrates what happens when we promise to w/w a (NOINLINE) leaf function, but+fail to deliver:++  data C = C Int# Int#++  {-# NOINLINE c1 #-}+  c1 :: C -> Int#+  c1 (C _ n) = n++  {-# NOINLINE fc #-}+  fc :: C -> Int#+  fc c = 2 *# c1 c++Failing to w/w `c1`, but still w/wing `fc` leads to the following code:++  c1 :: C -> Int#+  c1 (C _ n) = n++  $wfc :: Int# -> Int#+  $wfc n = let c = C 0# n in 2 #* c1 c++  fc :: C -> Int#+  fc (C _ n) = $wfc n++Yikes! The reboxed `C` in `$wfc` can't cancel out, so we are in a bad place.+This generalises to any function that derives its strictness signature from+its callees, so we have to make sure that when a function announces particular+strictness properties, we have to w/w them accordingly, even if it means+splitting a NOINLINE function.+ Note [Worker activation] ~~~~~~~~~~~~~~~~~~~~~~~~ Follows on from Note [Worker-wrapper for INLINABLE functions]@@ -357,7 +389,7 @@    Note [Worker-wrapper for NOINLINE functions]  3. For ordinary functions with no pragmas we want to inline the-   wrapper as early as possible (Trac #15056).  Suppose another module+   wrapper as early as possible (#15056).  Suppose another module    defines    f x = g x x    and suppose there is some RULE for (g True True).  Then if we have    a call (f True), we'd expect to inline 'f' and the RULE will fire.@@ -426,7 +458,7 @@         -- See Note [Don't w/w INLINE things]         -- See Note [Don't w/w inline small non-loop-breaker things] -  | is_fun+  | is_fun && is_eta_exp   = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds res_info rhs    | is_thunk                                   -- See Note [Thunk splitting]@@ -443,9 +475,11 @@         -- See Note [Zapping DmdEnv after Demand Analyzer] and         -- See Note [Zapping Used Once info in WorkWrap] -    is_fun    = notNull wrap_dmds || isJoinId fn_id-    is_thunk  = not is_fun && not (exprIsHNF rhs) && not (isJoinId fn_id)-                           && not (isUnliftedType (idType fn_id))+    is_fun     = notNull wrap_dmds || isJoinId fn_id+    -- See Note [Don't eta expand in w/w]+    is_eta_exp = length wrap_dmds == manifestArity rhs+    is_thunk   = not is_fun && not (exprIsHNF rhs) && not (isJoinId fn_id)+                            && not (isUnliftedType (idType fn_id))  {- Note [Zapping DmdEnv after Demand Analyzer]@@ -485,6 +519,36 @@  We do not do it in the demand analyser for the same reasons outlined in Note [Zapping DmdEnv after Demand Analyzer] above.++Note [Don't eta expand in w/w]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A binding where the manifestArity of the RHS is less than idArity of the binder+means CoreArity didn't eta expand that binding. When this happens, it does so+for a reason (see Note [exprArity invariant] in CoreArity) and we probably have+a PAP, cast or trivial expression as RHS.++Performing the worker/wrapper split will implicitly eta-expand the binding to+idArity, overriding CoreArity's decision. Other than playing fast and loose with+divergence, it's also broken for newtypes:++  f = (\xy.blah) |> co+    where+      co :: (Int -> Int -> Char) ~ T++Then idArity is 2 (despite the type T), and it can have a StrictSig based on a+threshold of 2. But we can't w/w it without a type error.++The situation is less grave for PAPs, but the implicit eta expansion caused a+compiler allocation regression in T15164, where huge recursive instance method+groups, mostly consisting of PAPs, got w/w'd. This caused great churn in the+simplifier, when simply waiting for the PAPs to inline arrived at the same+output program.++Note there is the worry here that such PAPs and trivial RHSs might not *always*+be inlined. That would lead to reboxing, because the analysis tacitly assumes+that we W/W'd for idArity and will propagate analysis information under that+assumption. So far, this doesn't seem to matter in practice.+See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064. -}
compiler/stranal/WwLib.hs view
@@ -11,12 +11,12 @@              , isWorkerSmallEnough  ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import CoreSyn-import CoreUtils        ( exprType, mkCast )+import CoreUtils        ( exprType, mkCast, mkDefaultCase, mkSingleAltCase ) import Id import IdInfo           ( JoinArity ) import DataCon@@ -30,6 +30,7 @@ import VarEnv           ( mkInScopeSet ) import VarSet           ( VarSet ) import Type+import Predicate        ( isClassPred ) import RepType          ( isVoidTy, typePrimRep ) import Coercion import FamInstEnv@@ -134,7 +135,7 @@ -- wrap_fn_str E        = case x of { (a,b) -> --                        case a of { (a1,a2) -> --                        E a1 a2 b y }}--- work_fn_str E        = \a2 a2 b y ->+-- work_fn_str E        = \a1 a2 b y -> --                        let a = (a1,a2) in --                        let x = (a,b) in --                        E@@ -214,12 +215,12 @@ And if something *has* been given the CPR property and we don't w/w, it's a disaster, because then the enclosing function might say it has the CPR property, but now doesn't and there a cascade of disaster.  A good example-is Trac #5920.+is #5920.  Note [Limit w/w arity] ~~~~~~~~~~~~~~~~~~~~~~~~ Guard against high worker arity as it generates a lot of stack traffic.-A simplified example is Trac #11565#comment:6+A simplified example is #11565#comment:6  Current strategy is very simple: don't perform w/w transformation at all if the result produces a wrapper with arity higher than -fmax-worker-args=.@@ -483,7 +484,7 @@    * We use a fresh unique for both type-variable and term-variable binders     Originally we lacked this freshness for type variables, and that led-    to the very obscure Trac #12562.  (A type variable in the worker shadowed+    to the very obscure #12562.  (A type variable in the worker shadowed     an outer term-variable binding.)    * Because of this cloning we have to substitute in the type/kind of the@@ -621,7 +622,7 @@                                          data_con unpk_args                 arg_no_unf = zapStableUnfolding arg                              -- See Note [Zap unfolding when beta-reducing]-                             -- in Simplify.hs; and see Trac #13890+                             -- in Simplify.hs; and see #13890                 rebox_fn   = Let (NonRec arg_no_unf con_app)                 con_app    = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co          ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False unpk_args@@ -836,7 +837,7 @@ Note [mkWWstr and unsafeCoerce] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ By using unsafeCoerce, it is possible to make the number of demands fail to-match the number of constructor arguments; this happened in Trac #8037.+match the number of constructor arguments; this happened in #8037. If so, the worker/wrapper split doesn't work right and we get a Core Lint bug.  The fix here is simply to decline to do w/w if that happens. @@ -875,10 +876,10 @@  Solution: use setCaseBndrEvald when creating  (A) The arg binders x1,x2 in mkWstr_one-         See Trac #13077, test T13077+         See #13077, test T13077  (B) The result binders r1,r2 in mkWWcpr_help          See Trace #13077, test T13077a-         And Trac #13027 comment:20, item (4)+         And #13027 comment:20, item (4) to record that the relevant binder is evaluated.  @@ -901,13 +902,13 @@ BUT if f is strict in the Ord dictionary, we might unpack it, to get    fw :: (a->a->Bool) -> [a] -> Int# -> a and the type-class specialiser can't specialise that.  An example is-Trac #6056.+#6056.  But in any other situation a dictionary is just an ordinary value, and can be unpacked.  So we track the INLINABLE pragma, and switch off the unpacking in mkWWstr_one (see the isClassPred test). -Historical note: Trac #14955 describes how I got this fix wrong+Historical note: #14955 describes how I got this fix wrong the first time. -} @@ -1027,10 +1028,10 @@              con_app   = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co         ; return ( True-                , \ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)]+                , \ wkr_call -> mkDefaultCase wkr_call arg con_app                 , \ body     -> mkUnpackCase body co work_uniq data_con [arg] (varToCoreExpr arg)                                 -- varToCoreExpr important here: arg can be a coercion-                                -- Lacking this caused Trac #10658+                                -- Lacking this caused #10658                 , arg_ty1 ) }    | otherwise   -- The general case@@ -1042,9 +1043,11 @@              ubx_tup_ty  = exprType ubx_tup_app              ubx_tup_app = mkCoreUbxTup (map fst arg_tys) (map varToCoreExpr args)              con_app     = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co+             tup_con     = tupleDataCon Unboxed (length arg_tys)         ; return (True-                , \ wkr_call -> Case wkr_call wrap_wild (exprType con_app)  [(DataAlt (tupleDataCon Unboxed (length arg_tys)), args, con_app)]+                , \ wkr_call -> mkSingleAltCase wkr_call wrap_wild+                                                (DataAlt tup_con) args con_app                 , \ body     -> mkUnpackCase body co work_uniq data_con args ubx_tup_app                 , ubx_tup_ty ) } @@ -1056,8 +1059,8 @@ mkUnpackCase (Tick tickish e) co uniq con args body   -- See Note [Profiling and unpacking]   = Tick tickish (mkUnpackCase e co uniq con args body) mkUnpackCase scrut co uniq boxing_con unpk_args body-  = Case casted_scrut bndr (exprType body)-         [(DataAlt boxing_con, unpk_args, body)]+  = mkSingleAltCase casted_scrut bndr+                    (DataAlt boxing_con) unpk_args body   where     casted_scrut = scrut `mkCast` co     bndr = mk_ww_local uniq (exprType casted_scrut, MarkedStrict)@@ -1115,7 +1118,7 @@ buggily is used we'll get a runtime error message.  Coping with absence for *unlifted* types is important; see, for-example, Trac #4306 and Trac #15627.  In the UnliftedRep case, we can+example, #4306 and #15627.  In the UnliftedRep case, we can use LitRubbish, which we need to apply to the required type. For the unlifted types of singleton kind like Float#, Addr#, etc. we also find a suitable literal, using Literal.absentLiteralOf.  We don't@@ -1167,7 +1170,7 @@   = WARN( True, text "No absent value for" <+> ppr arg_ty )     Nothing -- Can happen for 'State#' and things of 'VecRep'   where-    lifted_arg   = arg `setIdStrictness` exnSig+    lifted_arg   = arg `setIdStrictness` botSig               -- Note in strictness signature that this is bottoming               -- (for the sake of the "empty case scrutinee not known to               -- diverge for sure lint" warning)
compiler/typecheck/ClsInst.hs view
@@ -3,20 +3,21 @@ module ClsInst (      matchGlobalInst,      ClsInstResult(..),-     InstanceWhat(..), safeOverlap,+     InstanceWhat(..), safeOverlap, instanceReturnsDictCon,      AssocInstInfo(..), isNotAssociated   ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import TcEnv import TcRnMonad import TcType+import TcTypeable import TcMType import TcEvidence-import TcTypeableValidity+import Predicate import RnEnv( addUsedGRE ) import RdrName( lookupGRE_FieldLabel ) import InstEnv@@ -31,7 +32,7 @@ import Type import MkCore ( mkStringExprFS, mkNaturalExpr ) -import Name   ( Name )+import Name   ( Name, pprDefinedAt ) import VarEnv ( VarEnv ) import DataCon import TyCon@@ -91,6 +92,8 @@  data InstanceWhat   = BuiltinInstance+  | BuiltinEqInstance   -- A built-in "equality instance"; see the+                        -- TcSMonad Note [Solved dictionaries]   | LocalInstance   | TopLevInstance { iw_dfun_id   :: DFunId                    , iw_safe_over :: SafeOverlapping }@@ -103,15 +106,24 @@     = text "OneInst" <+> vcat [ppr ev, ppr what]  instance Outputable InstanceWhat where-  ppr BuiltinInstance = text "built-in instance"-  ppr LocalInstance   = text "locally-quantified instance"-  ppr (TopLevInstance { iw_safe_over = so })-     = text "top-level instance" <+> (text $ if so then "[safe]" else "[unsafe]")+  ppr BuiltinInstance   = text "a built-in instance"+  ppr BuiltinEqInstance = text "a built-in equality instance"+  ppr LocalInstance     = text "a locally-quantified instance"+  ppr (TopLevInstance { iw_dfun_id = dfun })+      = hang (text "instance" <+> pprSigmaType (idType dfun))+           2 (text "--" <+> pprDefinedAt (idName dfun))  safeOverlap :: InstanceWhat -> Bool safeOverlap (TopLevInstance { iw_safe_over = so }) = so safeOverlap _                                      = True +instanceReturnsDictCon :: InstanceWhat -> Bool+-- See Note [Solved dictionaries] in TcSMonad+instanceReturnsDictCon (TopLevInstance {}) = True+instanceReturnsDictCon BuiltinInstance     = True+instanceReturnsDictCon BuiltinEqInstance   = False+instanceReturnsDictCon LocalInstance       = False+ matchGlobalInst :: DynFlags                 -> Bool      -- True <=> caller is the short-cut solver                              -- See Note [Shortcut solving: overlap]@@ -162,7 +174,7 @@                 , isOverlappable ispec                 -- If the instance has OVERLAPPABLE or OVERLAPS or INCOHERENT                 -- then don't let the short-cut solver choose it, because a-                -- later instance might overlap it.  Trac #14434 is an example+                -- later instance might overlap it.  #14434 is an example                 -- See Note [Shortcut solving: overlap]                 -> do { traceTc "matchClass: ignoring overlappable" (ppr pred)                       ; return NotSure }@@ -207,13 +219,13 @@  We don't want to solve the wanted constraint with the overlappable instance; rather we want to use the supplied (C a)! That was the whole-point of it being overlappable!  Trac #14434 wwas an example.+point of it being overlappable!  #14434 wwas an example.  Alas even if the instance has no overlap flag, thus   instance C a where ... there is nothing to stop it being overlapped. GHC provides no way to declare an instance as "final" so it can't be overlapped.  But really-only final instances are OK for short-cut solving.  Sigh. Trac #15135+only final instances are OK for short-cut solving.  Sigh. #15135 was a puzzling example. -} @@ -514,7 +526,7 @@    Typeable (() => Int)    Typeable (((),()) => Int) -See Trac #9858.  For forall's the case is clear: we simply don't have+See #9858.  For forall's the case is clear: we simply don't have a TypeRep for them.  For qualified but not polymorphic types, like (Eq a => a -> a), things are murkier.  But: @@ -561,14 +573,14 @@ matchHeteroEquality args   = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon args ]                     , cir_mk_ev     = evDataConApp heqDataCon args-                    , cir_what      = BuiltinInstance })+                    , cir_what      = BuiltinEqInstance })  matchHomoEquality :: [Type] -> TcM ClsInstResult -- Solves (t1 ~ t2) matchHomoEquality args@[k,t1,t2]   = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon [k,k,t1,t2] ]                     , cir_mk_ev     = evDataConApp eqDataCon args-                    , cir_what      = BuiltinInstance })+                    , cir_what      = BuiltinEqInstance }) matchHomoEquality args = pprPanic "matchHomoEquality" (ppr args)  -- See also Note [The equality types story] in TysPrim@@ -576,7 +588,7 @@ matchCoercible args@[k, t1, t2]   = return (OneInst { cir_new_theta = [ mkTyConApp eqReprPrimTyCon args' ]                     , cir_mk_ev     = evDataConApp coercibleDataCon args-                    , cir_what      = BuiltinInstance })+                    , cir_what      = BuiltinEqInstance })   where     args' = [k, k, t1, t2] matchCoercible args = pprPanic "matchLiftedCoercible" (ppr args)@@ -671,7 +683,7 @@                          -- the HasField x r a dictionary.  The preds will                          -- typically be empty, but if the datatype has a                          -- "stupid theta" then we have to include it here.-                   ; let theta = mkPrimEqPred sel_ty (mkFunTy r_ty a_ty) : preds+                   ; let theta = mkPrimEqPred sel_ty (mkVisFunTy r_ty a_ty) : preds                           -- Use the equality proof to cast the selector Id to                          -- type (r -> a), then use the newtype coercion to cast
compiler/typecheck/FamInst.hs view
@@ -1,6 +1,6 @@ -- The @FamInst@ type: family instance heads -{-# LANGUAGE CPP, GADTs #-}+{-# LANGUAGE CPP, GADTs, ViewPatterns #-}  module FamInst (         FamInstEnvs, tcGetFamInstEnvs,@@ -10,7 +10,7 @@         newFamInst,          -- * Injectivity-        makeInjectivityErrors, injTyVarsOfType, injTyVarsOfTypes+        reportInjectivityErrors, reportConflictingInjectivityErrs     ) where  import GhcPrelude@@ -34,18 +34,22 @@ import RdrName import DataCon ( dataConName ) import Maybes-import Type import TyCoRep+import TyCoFVs+import TyCoPpr ( pprWithExplicitKindsWhen ) import TcMType import Name-import Pair import Panic import VarSet+import FV import Bag( Bag, unionBags, unitBag ) import Control.Monad+import Data.List.NonEmpty ( NonEmpty(..) ) -#include "GhclibHsVersions.h"+import qualified GHC.LanguageExtensions  as LangExt +#include "HsVersions.h"+ {- Note [The type family instance consistency story] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -158,8 +162,10 @@ -- Freshen the type variables of the FamInst branches newFamInst flavor axiom@(CoAxiom { co_ax_tc = fam_tc })   = ASSERT2( tyCoVarsOfTypes lhs `subVarSet` tcv_set, text "lhs" <+> pp_ax )-    ASSERT2( tyCoVarsOfType  rhs `subVarSet` tcv_set, text "rhs" <+> pp_ax )     ASSERT2( lhs_kind `eqType` rhs_kind, text "kind" <+> pp_ax $$ ppr lhs_kind $$ ppr rhs_kind )+    -- We used to have an assertion that the tyvars of the RHS were bound+    -- by tcv_set, but in error situations like  F Int = a that isn't+    -- true; a later check in checkValidFamInst rejects it     do { (subst, tvs') <- freshenTyVarBndrs tvs        ; (subst, cvs') <- freshenCoVarBndrsX subst cvs        ; dflags <- getDynFlags@@ -299,13 +305,12 @@ -- See Note [The type family instance consistency story]. checkFamInstConsistency :: [Module] -> TcM () checkFamInstConsistency directlyImpMods-  = do { dflags     <- getDynFlags-       ; (eps, hpt) <- getEpsAndHpt+  = do { (eps, hpt) <- getEpsAndHpt        ; traceTc "checkFamInstConsistency" (ppr directlyImpMods)        ; let { -- Fetch the iface of a given module.  Must succeed as                -- all directly imported modules must already have been loaded.                modIface mod =-                 case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of+                 case lookupIfaceByModule hpt (eps_PIT eps) mod of                    Nothing    -> panicDoc "FamInst.checkFamInstConsistency"                                           (ppr mod $$ pprHPT hpt)                    Just iface -> iface@@ -317,7 +322,7 @@                -- Note [Checking family instance optimization]              ; modConsistent :: Module -> [Module]              ; modConsistent mod =-                 if mi_finsts (modIface mod) then mod:deps else deps+                 if mi_finsts (mi_final_exts (modIface mod)) then mod:deps else deps                  where                  deps = dep_finsts . mi_deps . modIface $ mod @@ -678,10 +683,13 @@              home_fie' = extendFamInstEnv home_fie fam_inst             -- Check for conflicting instance decls and injectivity violations-       ; no_conflict    <- checkForConflicts            inst_envs fam_inst-       ; injectivity_ok <- checkForInjectivityConflicts inst_envs fam_inst+       ; ((), no_errs) <- askNoErrs $+         do { checkForConflicts            inst_envs fam_inst+            ; checkForInjectivityConflicts inst_envs fam_inst+            ; checkInjectiveEquation       fam_inst+            } -       ; if no_conflict && injectivity_ok then+       ; if no_errs then             return (home_fie', fam_inst : my_fis)          else             return (home_fie,  my_fis) }@@ -697,7 +705,8 @@ environments (one for the EPS and one for the HPT). -} -checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool+-- | Checks to make sure no two family instances overlap.+checkForConflicts :: FamInstEnvs -> FamInst -> TcM () checkForConflicts inst_envs fam_inst   = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst        ; traceTc "checkForConflicts" $@@ -705,136 +714,74 @@               , ppr fam_inst               -- , ppr inst_envs          ]-       ; reportConflictInstErr fam_inst conflicts-       ; return (null conflicts) }+       ; reportConflictInstErr fam_inst conflicts } +checkForInjectivityConflicts :: FamInstEnvs -> FamInst -> TcM ()+  -- see Note [Verifying injectivity annotation] in FamInstEnv, check 1B1.+checkForInjectivityConflicts instEnvs famInst+    | isTypeFamilyTyCon tycon   -- as opposed to data family tycon+    , Injective inj <- tyConInjectivityInfo tycon+    = let conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst in+      reportConflictingInjectivityErrs tycon conflicts (coAxiomSingleBranch (fi_axiom famInst))++    | otherwise+    = return ()++    where tycon = famInstTyCon famInst+ -- | Check whether a new open type family equation can be added without -- violating injectivity annotation supplied by the user. Returns True when -- this is possible and False if adding this equation would violate injectivity--- annotation.-checkForInjectivityConflicts :: FamInstEnvs -> FamInst -> TcM Bool-checkForInjectivityConflicts instEnvs famInst+-- annotation. This looks only at the one equation; it does not look for+-- interaction between equations. Use checkForInjectivityConflicts for that.+-- Does checks (2)-(4) of Note [Verifying injectivity annotation] in FamInstEnv.+checkInjectiveEquation :: FamInst -> TcM ()+checkInjectiveEquation famInst     | isTypeFamilyTyCon tycon     -- type family is injective in at least one argument     , Injective inj <- tyConInjectivityInfo tycon = do-    { let axiom = coAxiomSingleBranch fi_ax-          conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst+    { dflags <- getDynFlags+    ; let axiom = coAxiomSingleBranch fi_ax           -- see Note [Verifying injectivity annotation] in FamInstEnv-          errs = makeInjectivityErrors fi_ax axiom inj conflicts-    ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err) errs-    ; return (null errs)+    ; reportInjectivityErrors dflags fi_ax axiom inj     }      -- if there was no injectivity annotation or tycon does not represent a     -- type family we report no conflicts-    | otherwise = return True+    | otherwise+    = return ()+     where tycon = famInstTyCon famInst           fi_ax = fi_axiom famInst --- | Build a list of injectivity errors together with their source locations.-makeInjectivityErrors-   :: CoAxiom br   -- ^ Type family for which we generate errors+-- | Report a list of injectivity errors together with their source locations.+-- Looks only at one equation; does not look for conflicts *among* equations.+reportInjectivityErrors+   :: DynFlags+   -> CoAxiom br   -- ^ Type family for which we generate errors    -> CoAxBranch   -- ^ Currently checked equation (represented by axiom)    -> [Bool]       -- ^ Injectivity annotation-   -> [CoAxBranch] -- ^ List of injectivity conflicts-   -> [(SDoc, SrcSpan)]-makeInjectivityErrors fi_ax axiom inj conflicts+   -> TcM ()+reportInjectivityErrors dflags fi_ax axiom inj   = ASSERT2( any id inj, text "No injective type variables" )-    let lhs             = coAxBranchLHS axiom-        rhs             = coAxBranchRHS axiom-        fam_tc          = coAxiomTyCon fi_ax-        are_conflicts   = not $ null conflicts-        unused_inj_tvs  = unusedInjTvsInRHS fam_tc inj lhs rhs-        inj_tvs_unused  = not $ and (isEmptyVarSet <$> unused_inj_tvs)-        tf_headed       = isTFHeaded rhs-        bare_variables  = bareTvInRHSViolated lhs rhs-        wrong_bare_rhs  = not $ null bare_variables--        err_builder herald eqns-                        = ( hang herald-                               2 (vcat (map (pprCoAxBranchUser fam_tc) eqns))-                          , coAxBranchSpan (head eqns) )-        errorIf p f     = if p then [f err_builder axiom] else []-     in    errorIf are_conflicts  (conflictInjInstErr     conflicts     )-        ++ errorIf inj_tvs_unused (unusedInjectiveVarsErr unused_inj_tvs)-        ++ errorIf tf_headed       tfHeadedErr-        ++ errorIf wrong_bare_rhs (bareVariableInRHSErr   bare_variables)----- | Return a list of type variables that the function is injective in and that--- do not appear on injective positions in the RHS of a family instance--- declaration. The returned Pair includes invisible vars followed by visible ones-unusedInjTvsInRHS :: TyCon -> [Bool] -> [Type] -> Type -> Pair TyVarSet--- INVARIANT: [Bool] list contains at least one True value--- See Note [Verifying injectivity annotation]. This function implements fourth--- check described there.--- In theory, instead of implementing this whole check in this way, we could--- attempt to unify equation with itself.  We would reject exactly the same--- equations but this method gives us more precise error messages by returning--- precise names of variables that are not mentioned in the RHS.-unusedInjTvsInRHS tycon injList lhs rhs =-  (`minusVarSet` injRhsVars) <$> injLHSVars-    where-      inj_pairs :: [(Type, ArgFlag)]-      -- All the injective arguments, paired with their visibility-      inj_pairs = ASSERT2( injList `equalLength` lhs-                         , ppr tycon $$ ppr injList $$ ppr lhs )-                  filterByList injList (lhs `zip` tyConArgFlags tycon lhs)--      -- set of type and kind variables in which type family is injective-      invis_lhs, vis_lhs :: [Type]-      (invis_lhs, vis_lhs) = partitionInvisibles inj_pairs--      invis_vars = tyCoVarsOfTypes invis_lhs-      Pair invis_vars' vis_vars = splitVisVarsOfTypes vis_lhs-      injLHSVars-        = Pair (invis_vars `minusVarSet` vis_vars `unionVarSet` invis_vars')-               vis_vars--      -- set of type variables appearing in the RHS on an injective position.-      -- For all returned variables we assume their associated kind variables-      -- also appear in the RHS.-      injRhsVars = injTyVarsOfType rhs--injTyVarsOfType :: TcTauType -> TcTyVarSet--- Collect all type variables that are either arguments to a type---   constructor or to /injective/ type families.--- Determining the overall type determines thes variables------ E.g.   Suppose F is injective in its second arg, but not its first---        then injVarOfType (Either a (F [b] (a,c))) = {a,c}---        Determining the overall type determines a,c but not b.-injTyVarsOfType ty-  | Just ty' <- coreView ty -- #12430-  = injTyVarsOfType ty'-injTyVarsOfType (TyVarTy v)-  = unitVarSet v `unionVarSet` injTyVarsOfType (tyVarKind v)-injTyVarsOfType (TyConApp tc tys)-  | isTypeFamilyTyCon tc-   = case tyConInjectivityInfo tc of-        NotInjective  -> emptyVarSet-        Injective inj -> injTyVarsOfTypes (filterByList inj tys)-  | otherwise-  = injTyVarsOfTypes tys-injTyVarsOfType (LitTy {})-  = emptyVarSet-injTyVarsOfType (FunTy arg res)-  = injTyVarsOfType arg `unionVarSet` injTyVarsOfType res-injTyVarsOfType (AppTy fun arg)-  = injTyVarsOfType fun `unionVarSet` injTyVarsOfType arg--- No forall types in the RHS of a type family-injTyVarsOfType (CastTy ty _)   = injTyVarsOfType ty-injTyVarsOfType (CoercionTy {}) = emptyVarSet-injTyVarsOfType (ForAllTy {})    =-    panic "unusedInjTvsInRHS.injTyVarsOfType"+    do let lhs             = coAxBranchLHS axiom+           rhs             = coAxBranchRHS axiom+           fam_tc          = coAxiomTyCon fi_ax+           (unused_inj_tvs, unused_vis, undec_inst_flag)+                           = unusedInjTvsInRHS dflags fam_tc lhs rhs+           inj_tvs_unused  = not $ isEmptyVarSet unused_inj_tvs+           tf_headed       = isTFHeaded rhs+           bare_variables  = bareTvInRHSViolated lhs rhs+           wrong_bare_rhs  = not $ null bare_variables -injTyVarsOfTypes :: [Type] -> VarSet-injTyVarsOfTypes tys = mapUnionVarSet injTyVarsOfType tys+       when inj_tvs_unused $ reportUnusedInjectiveVarsErr fam_tc unused_inj_tvs+                                                          unused_vis undec_inst_flag axiom+       when tf_headed      $ reportTfHeadedErr            fam_tc axiom+       when wrong_bare_rhs $ reportBareVariableInRHSErr   fam_tc bare_variables axiom  -- | Is type headed by a type family application? isTFHeaded :: Type -> Bool--- See Note [Verifying injectivity annotation]. This function implements third--- check described there.+-- See Note [Verifying injectivity annotation], case 3. isTFHeaded ty | Just ty' <- coreView ty               = isTFHeaded ty' isTFHeaded ty | (TyConApp tc args) <- ty@@ -846,85 +793,239 @@ -- | If a RHS is a bare type variable return a set of LHS patterns that are not -- bare type variables. bareTvInRHSViolated :: [Type] -> Type -> [Type]--- See Note [Verifying injectivity annotation]. This function implements second--- check described there.+-- See Note [Verifying injectivity annotation], case 2. bareTvInRHSViolated pats rhs | isTyVarTy rhs    = filter (not . isTyVarTy) pats bareTvInRHSViolated _ _ = [] +------------------------------------------------------------------+-- Checking for the coverage condition for injective type families+------------------------------------------------------------------ --- | Type of functions that use error message and a list of axioms to build full--- error message (with a source location) for injective type families.-type InjErrorBuilder = SDoc -> [CoAxBranch] -> (SDoc, SrcSpan)+{-+Note [Coverage condition for injective type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The Injective Type Families paper describes how we can tell whether+or not a type family equation upholds the injectivity condition.+Briefly, consider the following: --- | Build injecivity error herald common to all injectivity errors.-injectivityErrorHerald :: Bool -> SDoc-injectivityErrorHerald isSingular =-  text "Type family equation" <> s isSingular <+> text "violate" <>-  s (not isSingular) <+> text "injectivity annotation" <>-  if isSingular then dot else colon-  -- Above is an ugly hack.  We want this: "sentence. herald:" (note the dot and-  -- colon).  But if herald is empty we want "sentence:" (note the colon).  We-  -- can't test herald for emptiness so we rely on the fact that herald is empty-  -- only when isSingular is False.  If herald is non empty it must end with a-  -- colon.-    where-      s False = text "s"-      s True  = empty+  type family F a b = r | r -> a      -- NB: b is not injective --- | Build error message for a pair of equations violating an injectivity--- annotation.-conflictInjInstErr :: [CoAxBranch] -> InjErrorBuilder -> CoAxBranch-                   -> (SDoc, SrcSpan)-conflictInjInstErr conflictingEqns errorBuilder tyfamEqn-  | confEqn : _ <- conflictingEqns-  = errorBuilder (injectivityErrorHerald False) [confEqn, tyfamEqn]-  | otherwise-  = panic "conflictInjInstErr"+  type instance F ty1 ty2 = ty3 --- | Build error message for equation with injective type variables unused in--- the RHS.-unusedInjectiveVarsErr :: Pair TyVarSet -> InjErrorBuilder -> CoAxBranch-                       -> (SDoc, SrcSpan)-unusedInjectiveVarsErr (Pair invis_vars vis_vars) errorBuilder tyfamEqn-  = let (doc, loc) = errorBuilder (injectivityErrorHerald True $$ msg)-                                  [tyfamEqn]-    in (pprWithExplicitKindsWhen has_kinds doc, loc)+We need to make sure that all variables mentioned in ty1 are mentioned in ty3+-- that's how we know that knowing ty3 determines ty1. But they can't be+mentioned just anywhere in ty3: they must be in *injective* positions in ty3.+For example:++  type instance F a Int = Maybe (G a)++This is no good, if G is not injective. However, if G is indeed injective,+then this would appear to meet our needs. There is a trap here, though: while+knowing G a does indeed determine a, trying to compute a from G a might not+terminate. This is precisely the same problem that we have with functional+dependencies and their liberal coverage condition. Here is the test case:++  type family G a = r | r -> a+  type instance G [a] = [G a]+  [W] G alpha ~ [alpha]++We see that the equation given applies, because G alpha equals a list. So we+learn that alpha must be [beta] for some beta. We then have++  [W] G [beta] ~ [[beta]]++This can reduce to++  [W] [G beta] ~ [[beta]]++which then decomposes to++  [W] G beta ~ [beta]++right where we started. The equation G [a] = [G a] thus is dangerous: while+it does not violate the injectivity assumption, it might throw us into a loop,+with a particularly dastardly Wanted.++We thus do what functional dependencies do: require -XUndecidableInstances to+accept this.++Checking the coverage condition is not terribly hard, but we also want to produce+a nice error message. A nice error message has at least two properties:++1. If any of the variables involved are invisible or are used in an invisible context,+we want to print invisible arguments (as -fprint-explicit-kinds does).++2. If we fail to accept the equation because we're worried about non-termination,+we want to suggest UndecidableInstances.++To gather the right information, we can talk about the *usage* of a variable. Every+variable is used either visibly or invisibly, and it is either not used at all,+in a context where acceptance requires UndecidableInstances, or in a context that+does not require UndecidableInstances. If a variable is used both visibly and+invisibly, then we want to remember the fact that it was used invisibly: printing+out invisibles will be helpful for the user to understand what is going on.+If a variable is used where we need -XUndecidableInstances and where we don't,+we can similarly just remember the latter.++We thus define Visibility and NeedsUndecInstFlag below. These enumerations are+*ordered*, and we used their Ord instances. We then define VarUsage, which is just a pair+of a Visibility and a NeedsUndecInstFlag. (The visibility is irrelevant when a+variable is NotPresent, but this extra slack in the representation causes no+harm.) We finally define VarUsages as a mapping from variables to VarUsage.+Its Monoid instance combines two maps, using the Semigroup instance of VarUsage+to combine elements that are represented in both maps. In this way, we can+compositionally analyze types (and portions thereof).++To do the injectivity check:++1. We build VarUsages that represent the LHS (rather, the portion of the LHS+that is flagged as injective); each usage on the LHS is NotPresent, because we+hvae not yet looked at the RHS.++2. We also build a VarUsage for the RHS, done by injTyVarUsages.++3. We then combine these maps. Now, every variable in the injective components of the LHS+will be mapped to its correct usage (either NotPresent or perhaps needing+-XUndecidableInstances in order to be seen as injective).++4. We look up each var used in an injective argument on the LHS in+the map, making a list of tvs that should be determined by the RHS+but aren't.++5. We then return the set of bad variables, whether any of the bad+ones were used invisibly, and whether any bad ones need -XUndecidableInstances.+If -XUndecidableInstances is enabled, than a var that needs the flag+won't be bad, so it won't appear in this list.++6. We use all this information to produce a nice error message, (a) switching+on -fprint-explicit-kinds if appropriate and (b) telling the user about+-XUndecidableInstances if appropriate.++-}++-- | Return the set of type variables that a type family equation is+-- expected to be injective in but is not. Suppose we have @type family+-- F a b = r | r -> a@. Then any variables that appear free in the first+-- argument to F in an equation must be fixed by that equation's RHS.+-- This function returns all such variables that are not indeed fixed.+-- It also returns whether any of these variables appear invisibly+-- and whether -XUndecidableInstances would help.+-- See Note [Coverage condition for injective type families].+unusedInjTvsInRHS :: DynFlags+                  -> TyCon  -- type family+                  -> [Type] -- LHS arguments+                  -> Type   -- the RHS+                  -> ( TyVarSet+                     , Bool   -- True <=> one or more variable is used invisibly+                     , Bool ) -- True <=> suggest -XUndecidableInstances+-- See Note [Verifying injectivity annotation] in FamInstEnv.+-- This function implements check (4) described there, further+-- described in Note [Coverage condition for injective type families].+-- In theory (and modulo the -XUndecidableInstances wrinkle),+-- instead of implementing this whole check in this way, we could+-- attempt to unify equation with itself.  We would reject exactly the same+-- equations but this method gives us more precise error messages by returning+-- precise names of variables that are not mentioned in the RHS.+unusedInjTvsInRHS dflags tycon@(tyConInjectivityInfo -> Injective inj_list) lhs rhs =+  -- Note [Coverage condition for injective type families], step 5+  (bad_vars, any_invisible, suggest_undec)     where-      tvs = invis_vars `unionVarSet` vis_vars-      has_types = not $ isEmptyVarSet vis_vars-      has_kinds = not $ isEmptyVarSet invis_vars+      undec_inst = xopt LangExt.UndecidableInstances dflags -      doc = sep [ what <+> text "variable" <>+      inj_lhs = filterByList inj_list lhs+      lhs_vars = tyCoVarsOfTypes inj_lhs++      rhs_inj_vars = fvVarSet $ injectiveVarsOfType undec_inst rhs++      bad_vars = lhs_vars `minusVarSet` rhs_inj_vars++      any_bad = not $ isEmptyVarSet bad_vars++      invis_vars = fvVarSet $ invisibleVarsOfTypes [mkTyConApp tycon lhs, rhs]++      any_invisible = any_bad && (bad_vars `intersectsVarSet` invis_vars)+      suggest_undec = any_bad &&+                      not undec_inst &&+                      (lhs_vars `subVarSet` fvVarSet (injectiveVarsOfType True rhs))++-- When the type family is not injective in any arguments+unusedInjTvsInRHS _ _ _ _ = (emptyVarSet, False, False)++---------------------------------------+-- Producing injectivity error messages+---------------------------------------++-- | Report error message for a pair of equations violating an injectivity+-- annotation. No error message if there are no branches.+reportConflictingInjectivityErrs :: TyCon -> [CoAxBranch] -> CoAxBranch -> TcM ()+reportConflictingInjectivityErrs _ [] _ = return ()+reportConflictingInjectivityErrs fam_tc (confEqn1:_) tyfamEqn+  = addErrs [buildInjectivityError fam_tc herald (confEqn1 :| [tyfamEqn])]+  where+    herald = text "Type family equation right-hand sides overlap; this violates" $$+             text "the family's injectivity annotation:"++-- | Injectivity error herald common to all injectivity errors.+injectivityErrorHerald :: SDoc+injectivityErrorHerald =+  text "Type family equation violates the family's injectivity annotation."+++-- | Report error message for equation with injective type variables unused in+-- the RHS. Note [Coverage condition for injective type families], step 6+reportUnusedInjectiveVarsErr :: TyCon+                             -> TyVarSet+                             -> Bool   -- True <=> print invisible arguments+                             -> Bool   -- True <=> suggest -XUndecidableInstances+                             -> CoAxBranch+                             -> TcM ()+reportUnusedInjectiveVarsErr fam_tc tvs has_kinds undec_inst tyfamEqn+  = let (loc, doc) = buildInjectivityError fam_tc+                                  (injectivityErrorHerald $$+                                   herald $$+                                   text "In the type family equation:")+                                  (tyfamEqn :| [])+    in addErrAt loc (pprWithExplicitKindsWhen has_kinds doc)+    where+      herald = sep [ what <+> text "variable" <>                   pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort)                 , text "cannot be inferred from the right-hand side." ]-      what = case (has_types, has_kinds) of-               (True, True)   -> text "Type and kind"-               (True, False)  -> text "Type"-               (False, True)  -> text "Kind"-               (False, False) -> pprPanic "mkUnusedInjectiveVarsErr" $ ppr tvs-      msg = doc $$ text "In the type family equation:"+               $$ extra --- | Build error message for equation that has a type family call at the top+      what | has_kinds = text "Type/kind"+           | otherwise = text "Type"++      extra | undec_inst = text "Using UndecidableInstances might help"+            | otherwise  = empty++-- | Report error message for equation that has a type family call at the top -- level of RHS-tfHeadedErr :: InjErrorBuilder -> CoAxBranch-            -> (SDoc, SrcSpan)-tfHeadedErr errorBuilder famInst-  = errorBuilder (injectivityErrorHerald True $$-                  text "RHS of injective type family equation cannot" <+>-                  text "be a type family:") [famInst]+reportTfHeadedErr :: TyCon -> CoAxBranch -> TcM ()+reportTfHeadedErr fam_tc branch+  = addErrs [buildInjectivityError fam_tc+               (injectivityErrorHerald $$+                 text "RHS of injective type family equation cannot" <+>+                 text "be a type family:")+               (branch :| [])] --- | Build error message for equation that has a bare type variable in the RHS+-- | Report error message for equation that has a bare type variable in the RHS -- but LHS pattern is not a bare type variable.-bareVariableInRHSErr :: [Type] -> InjErrorBuilder -> CoAxBranch-                     -> (SDoc, SrcSpan)-bareVariableInRHSErr tys errorBuilder famInst-  = errorBuilder (injectivityErrorHerald True $$+reportBareVariableInRHSErr :: TyCon -> [Type] -> CoAxBranch -> TcM ()+reportBareVariableInRHSErr fam_tc tys branch+  = addErrs [buildInjectivityError fam_tc+                 (injectivityErrorHerald $$                   text "RHS of injective type family equation is a bare" <+>                   text "type variable" $$                   text "but these LHS type and kind patterns are not bare" <+>-                  text "variables:" <+> pprQuotedList tys) [famInst]+                  text "variables:" <+> pprQuotedList tys)+                 (branch :| [])] +buildInjectivityError :: TyCon -> SDoc -> NonEmpty CoAxBranch -> (SrcSpan, SDoc)+buildInjectivityError fam_tc herald (eqn1 :| rest_eqns)+  = ( coAxBranchSpan eqn1+    , hang herald+         2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns))) )  reportConflictInstErr :: FamInst -> [FamInstMatch] -> TcRn () reportConflictInstErr _ []
compiler/typecheck/FunDeps.hs view
@@ -17,21 +17,24 @@         pprFundeps     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import Name import Var import Class+import Predicate import Type import TcType( transSuperClasses ) import CoAxiom( TypeEqn ) import Unify-import FamInst( injTyVarsOfTypes ) import InstEnv import VarSet import VarEnv+import TyCoFVs+import TyCoPpr( pprWithExplicitKindsWhen )+import FV import Outputable import ErrUtils( Validity(..), allValid ) import SrcLoc@@ -322,7 +325,7 @@                         --          (b) we must apply 'subst' to the kinds, in case we have                         --              matched out a kind variable, but not a type variable                         --              whose kind mentions that kind variable!-                        --          Trac #6015, #6068+                        --          #6015, #6068   where     (ltys1, rtys1) = instFD fd clas_tvs tys_inst     (ltys2, rtys2) = instFD fd clas_tvs tys_actual@@ -427,15 +430,15 @@ then fixing x really fixes k2 as well, and so k2 should be added to the lhs tyvars in the fundep check. -Example (Trac #8391), using liberal coverage+Example (#8391), using liberal coverage       data Foo a = ...  -- Foo :: forall k. k -> *       class Bar a b | a -> b       instance Bar a (Foo a)      In the instance decl, (a:k) does fix (Foo k a), but only if we notice-    that (a:k) fixes k.  Trac #10109 is another example.+    that (a:k) fixes k.  #10109 is another example. -Here is a more subtle example, from HList-0.4.0.0 (Trac #10564)+Here is a more subtle example, from HList-0.4.0.0 (#10564)    class HasFieldM (l :: k) r (v :: Maybe *)         | l r -> v where ...@@ -468,7 +471,7 @@   * And that fixes v.  However, we must closeOverKinds whenever augmenting the seed set-in oclose!  Consider Trac #10109:+in oclose!  Consider #10109:    data Succ a   -- Succ :: forall k. k -> *   class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab@@ -516,11 +519,11 @@ So when oclose expands superclasses we'll get a (a ~# [b]) superclass. But that's an EqPred not a ClassPred, and we jolly well do want to account for the mutual functional dependencies implied by (t1 ~# t2).-Hence the EqPred handling in oclose.  See Trac #10778.+Hence the EqPred handling in oclose.  See #10778.  Note [Care with type functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (Trac #12803)+Consider (#12803)   class C x y | x -> y   type family F a b   type family G c d = r | r -> d@@ -549,7 +552,7 @@             -- closeOverKinds: see Note [Closing over kinds in coverage]      tv_fds  :: [(TyCoVarSet,TyCoVarSet)]-    tv_fds  = [ (tyCoVarsOfTypes ls, injTyVarsOfTypes rs)+    tv_fds  = [ (tyCoVarsOfTypes ls, fvVarSet $ injectiveVarsOfTypes True rs)                   -- See Note [Care with type functions]               | pred <- preds               , pred' <- pred : transSuperClasses pred@@ -603,7 +606,7 @@ In checkFunDeps we check that a new ClsInst is consistent with all the ClsInsts in the environment. -The bogus aspect is discussed in Trac #10675. Currenty it if the two+The bogus aspect is discussed in #10675. Currenty it if the two types are *contradicatory*, using (isNothing . tcUnifyTys).  But all the papers say we should check if the two types are *equal* thus    not (substTys subst rtys1 `eqTypes` substTys subst rtys2)@@ -638,7 +641,7 @@       = case tcUnifyTyKis bind_fn ltys1 ltys2 of           Nothing         -> False           Just subst-            -> isNothing $   -- Bogus legacy test (Trac #10675)+            -> isNothing $   -- Bogus legacy test (#10675)                              -- See Note [Bogus consistency check]                tcUnifyTyKis bind_fn (substTysUnchecked subst rtys1) (substTysUnchecked subst rtys2)
compiler/typecheck/Inst.hs view
@@ -15,7 +15,7 @@        instCall, instDFunType, instStupidTheta, instTyVarsWith,        newWanted, newWanteds, -       tcInstTyBinders, tcInstTyBinder,+       tcInstInvisibleTyBinders, tcInstInvisibleTyBinder,         newOverloadedLit, mkOverLit, @@ -30,7 +30,7 @@        tyCoVarsOfCt, tyCoVarsOfCts,     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -39,9 +39,12 @@  import BasicTypes ( IntegralLit(..), SourceText(..) ) import FastString-import HsSyn+import GHC.Hs import TcHsSyn import TcRnMonad+import Constraint+import Predicate+import TcOrigin import TcEnv import TcEvidence import InstEnv@@ -51,6 +54,7 @@ import TcMType import Type import TyCoRep+import TyCoPpr     ( debugPprType ) import TcType import HscTypes import Class( Class )@@ -58,7 +62,7 @@ import CoreSyn( Expr(..) )  -- For the Coercion constructor import Id import Name-import Var      ( EvVar, mkTyVar, tyVarName, VarBndr(..) )+import Var      ( EvVar, tyVarName, VarBndr(..) ) import DataCon import VarEnv import PrelNames@@ -66,6 +70,7 @@ import DynFlags import Util import Outputable+import BasicTypes ( TypeOrKind(..) ) import qualified GHC.LanguageExtensions as LangExt  import Control.Monad( unless )@@ -78,26 +83,32 @@ ************************************************************************ -} -newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr GhcTcId)--- Used when Name is the wired-in name for a wired-in class method,+newMethodFromName+  :: CtOrigin              -- ^ why do we need this?+  -> Name                  -- ^ name of the method+  -> [TcRhoType]           -- ^ types with which to instantiate the class+  -> TcM (HsExpr GhcTcId)+-- ^ Used when 'Name' is the wired-in name for a wired-in class method, -- so the caller knows its type for sure, which should be of form---    forall a. C a => <blah>--- newMethodFromName is supposed to instantiate just the outer+--+-- > forall a. C a => <blah>+--+-- 'newMethodFromName' is supposed to instantiate just the outer -- type variable and constraint -newMethodFromName origin name inst_ty+newMethodFromName origin name ty_args   = do { id <- tcLookupId name               -- Use tcLookupId not tcLookupGlobalId; the method is almost               -- always a class op, but with -XRebindableSyntax GHC is               -- meant to find whatever thing is in scope, and that may               -- be an ordinary function. -       ; let ty = piResultTy (idType id) inst_ty+       ; let ty = piResultTys (idType id) ty_args              (theta, _caller_knows_this) = tcSplitPhiTy ty        ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )-                 instCall origin [inst_ty] theta+                 instCall origin ty_args theta -       ; return (mkHsWrap wrap (HsVar noExt (noLoc id))) }+       ; return (mkHsWrap wrap (HsVar noExtField (noLoc id))) }  {- ************************************************************************@@ -158,7 +169,7 @@                       <.> mkWpEvVarApps ids1                     , tv_prs1  ++ tvs_prs2                     , ev_vars1 ++ ev_vars2-                    , mkFunTys arg_tys' rho ) }+                    , mkVisFunTys arg_tys' rho ) }        | otherwise       = return (idHsWrapper, [], [], substTy subst ty)@@ -197,7 +208,7 @@        ; (subst, inst_tvs') <- mapAccumLM newMetaTyVarX empty_subst inst_tvs        ; let inst_theta' = substTheta subst inst_theta              sigma'      = substTy subst (mkForAllTys leave_bndrs $-                                          mkFunTys leave_theta rho)+                                          mkPhiTy leave_theta rho)              inst_tv_tys' = mkTyVarTys inst_tvs'         ; wrap1 <- instCall orig inst_tv_tys' inst_theta'@@ -272,7 +283,7 @@                     <.> wrap2                     <.> wrap1                     <.> mkWpEvVarApps ids1,-                 mkFunTys arg_tys' rho2) }+                 mkVisFunTys arg_tys' rho2) }    | otherwise   = do { let ty' = substTy subst ty@@ -287,28 +298,27 @@ instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM TCvSubst -- Use this when you want to instantiate (forall a b c. ty) with -- types [ta, tb, tc], but when the kinds of 'a' and 'ta' might--- not yet match (perhaps because there are unsolved constraints; Trac #14154)+-- not yet match (perhaps because there are unsolved constraints; #14154) -- If they don't match, emit a kind-equality to promise that they will -- eventually do so, and thus make a kind-homongeneous substitution. instTyVarsWith orig tvs tys-  = go empty_subst tvs tys+  = go emptyTCvSubst tvs tys   where-    empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes tys))-     go subst [] []       = return subst     go subst (tv:tvs) (ty:tys)       | tv_kind `tcEqType` ty_kind-      = go (extendTCvSubst subst tv ty) tvs tys+      = go (extendTvSubstAndInScope subst tv ty) tvs tys       | otherwise       = do { co <- emitWantedEq orig KindLevel Nominal ty_kind tv_kind-           ; go (extendTCvSubst subst tv (ty `mkCastTy` co)) tvs tys }+           ; go (extendTvSubstAndInScope subst tv (ty `mkCastTy` co)) tvs tys }       where         tv_kind = substTy subst (tyVarKind tv)         ty_kind = tcTypeKind ty      go _ _ _ = pprPanic "instTysWith" (ppr tvs $$ ppr tys) + {- ************************************************************************ *                                                                      *@@ -402,179 +412,76 @@   = do  { _co <- instCallConstraints orig theta -- Discard the coercion         ; return () } -{--************************************************************************++{- ********************************************************************* *                                                                      *          Instantiating Kinds *                                                                      *-************************************************************************--Note [Constraints handled in types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Generally, we cannot handle constraints written in types. For example,-if we declare--  data C a where-    MkC :: Show a => a -> C a--we will not be able to use MkC in types, as we have no way of creating-a type-level Show dictionary.--However, we make an exception for equality types. Consider--  data T1 a where-    MkT1 :: T1 Bool--  data T2 a where-    MkT2 :: a ~ Bool => T2 a--MkT1 has a constrained return type, while MkT2 uses an explicit equality-constraint. These two types are often written interchangeably, with a-reasonable expectation that they mean the same thing. For this to work ---and for us to be able to promote GADTs -- we need to be able to instantiate-equality constraints in types.--One wrinkle is that the equality in MkT2 is *lifted*. But, for proper-GADT equalities, GHC produces *unlifted* constraints. (This unlifting comes-from DataCon.eqSpecPreds, which uses mkPrimEqPred.) And, perhaps a wily-user will use (~~) for a heterogeneous equality. We thus must support-all of (~), (~~), and (~#) in types. (See Note [The equality types story]-in TysPrim for a primer on these equality types.)--The get_eq_tys_maybe function recognizes these three forms of equality,-returning a suitable type formation function and the two types related-by the equality constraint. In the lifted case, it uses mkHEqBoxTy or-mkEqBoxTy, which promote the datacons of the (~~) or (~) datatype,-respectively.--One might reasonably wonder who *unpacks* these boxes once they are-made. After all, there is no type-level `case` construct. The surprising-answer is that no one ever does. Instead, if a GADT constructor is used-on the left-hand side of a type family equation, that occurrence forces-GHC to unify the types in question. For example:--  data G a where-    MkG :: G Bool--  type family F (x :: G a) :: a where-    F MkG = False--When checking the LHS `F MkG`, GHC sees the MkG constructor and then must-unify F's implicit parameter `a` with Bool. This succeeds, making the equation--    F Bool (MkG @Bool <Bool>) = False--Note that we never need unpack the coercion. This is because type family-equations are *not* parametric in their kind variables. That is, we could have-just said--  type family H (x :: G a) :: a where-    H _ = False--The presence of False on the RHS also forces `a` to become Bool, giving us--    H Bool _ = False--The fact that any of this works stems from the lack of phase separation between-types and kinds (unlike the very present phase separation between terms and types).--Once we have the ability to pattern-match on types below top-level, this will-no longer cut it, but it seems fine for now.---}+********************************************************************* -} ------------------------------- | Instantantiate the TyConBinders of a forall type,---   given its decomposed form (tvs, ty)-tcInstTyBinders :: HasDebugCallStack-              => ([TyCoBinder], TcKind)   -- ^ The type (forall bs. ty)-              -> TcM ([TcType], TcKind)   -- ^ Instantiated bs, substituted ty--- Takes a pair because that is what splitPiTysInvisible returns--- See also Note [Bidirectional type checking]-tcInstTyBinders (bndrs, ty)-  | null bndrs        -- It's fine for bndrs to be empty e.g.-  = return ([], ty)   -- Check that (Maybe :: forall {k}. k->*),-                      --       and see the call to instTyBinders in checkExpectedKind-                      -- A user bug to be reported as such; it is not a compiler crash!+-- | Instantiates up to n invisible binders+-- Returns the instantiating types, and body kind+tcInstInvisibleTyBinders :: Int -> TcKind -> TcM ([TcType], TcKind) -  | otherwise-  = do { (subst, args) <- mapAccumLM (tcInstTyBinder Nothing) empty_subst bndrs-       ; ty' <- zonkTcType (substTy subst ty)-                   -- Why zonk the result? So that tcTyVar can-                   -- obey (IT6) of Note [The tcType invariant] in TcHsType-                   -- ToDo: SLPJ: I don't think this is needed-       ; return (args, ty') }+tcInstInvisibleTyBinders 0 kind+  = return ([], kind)+tcInstInvisibleTyBinders n ty+  = go n empty_subst ty   where-     empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))+    empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) --- | Used only in *types*-tcInstTyBinder :: Maybe (VarEnv Kind)-               -> TCvSubst -> TyBinder -> TcM (TCvSubst, TcType)-tcInstTyBinder mb_kind_info subst (Named (Bndr tv _))-  = case lookup_tv tv of-      Just ki -> return (extendTvSubstAndInScope subst tv ki, ki)-      Nothing -> do { (subst', tv') <- newMetaTyVarX subst tv-                    ; return (subst', mkTyVarTy tv') }-  where-    lookup_tv tv = do { env <- mb_kind_info   -- `Maybe` monad-                      ; lookupVarEnv env tv }+    go n subst kind+      | n > 0+      , Just (bndr, body) <- tcSplitPiTy_maybe kind+      , isInvisibleBinder bndr+      = do { (subst', arg) <- tcInstInvisibleTyBinder subst bndr+           ; (args, inner_ty) <- go (n-1) subst' body+           ; return (arg:args, inner_ty) }+      | otherwise+      = return ([], substTy subst kind) +-- | Used only in *types*+tcInstInvisibleTyBinder :: TCvSubst -> TyBinder -> TcM (TCvSubst, TcType)+tcInstInvisibleTyBinder subst (Named (Bndr tv _))+  = do { (subst', tv') <- newMetaTyVarX subst tv+       ; return (subst', mkTyVarTy tv') } -tcInstTyBinder _ subst (Anon ty)-     -- This is the *only* constraint currently handled in types.-  | Just (mk, k1, k2) <- get_eq_tys_maybe substed_ty-  = do { co <- unifyKind Nothing k1 k2+tcInstInvisibleTyBinder subst (Anon af ty)+  | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst ty)+    -- Equality is the *only* constraint currently handled in types.+    -- See Note [Constraints in kinds] in TyCoRep+  = ASSERT( af == InvisArg )+    do { co <- unifyKind Nothing k1 k2        ; arg' <- mk co        ; return (subst, arg') } -  | isPredTy substed_ty-  = do { let (env, tidy_ty) = tidyOpenType emptyTidyEnv substed_ty-       ; addErrTcM (env, text "Illegal constraint in a kind:" <+> ppr tidy_ty)+  | otherwise  -- This should never happen+               -- See TyCoRep Note [Constraints in kinds]+  = pprPanic "tcInvisibleTyBinder" (ppr ty) -         -- just invent a new variable so that we can continue-       ; u <- newUnique-       ; let name = mkSysTvName u (fsLit "dict")-       ; return (subst, mkTyVarTy $ mkTyVar name substed_ty) }+-------------------------------+get_eq_tys_maybe :: Type+                 -> Maybe ( Coercion -> TcM Type+                             -- given a coercion proving t1 ~# t2, produce the+                             -- right instantiation for the TyBinder at hand+                          , Type  -- t1+                          , Type  -- t2+                          )+-- See Note [Constraints in kinds] in TyCoRep+get_eq_tys_maybe ty+  -- Lifted heterogeneous equality (~~)+  | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty+  , tc `hasKey` heqTyConKey+  = Just (\co -> mkHEqBoxTy co k1 k2, k1, k2) +  -- Lifted homogeneous equality (~)+  | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty+  , tc `hasKey` eqTyConKey+  = Just (\co -> mkEqBoxTy co k1 k2, k1, k2)    | otherwise-  = do { tv_ty <- newFlexiTyVarTy substed_ty-       ; return (subst, tv_ty) }--  where-    substed_ty = substTy subst ty--      -- See Note [Constraints handled in types]-    get_eq_tys_maybe :: Type-                     -> Maybe ( Coercion -> TcM Type-                                 -- given a coercion proving t1 ~# t2, produce the-                                 -- right instantiation for the TyBinder at hand-                              , Type  -- t1-                              , Type  -- t2-                              )-    get_eq_tys_maybe ty-        -- unlifted equality (~#)-      | Just (Nominal, k1, k2) <- getEqPredTys_maybe ty-      = Just (\co -> return $ mkCoercionTy co, k1, k2)--        -- lifted heterogeneous equality (~~)-      | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty-      = if | tc `hasKey` heqTyConKey-             -> Just (\co -> mkHEqBoxTy co k1 k2, k1, k2)-           | otherwise-             -> Nothing--        -- lifted homogeneous equality (~)-      | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty-      = if | tc `hasKey` eqTyConKey-             -> Just (\co -> mkEqBoxTy co k1 k2, k1, k2)-           | otherwise-             -> Nothing--      | otherwise-      = Nothing+  = Nothing -------------------------------- -- | This takes @a ~# b@ and returns @a ~~ b@. mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type -- monadic just for convenience with mkEqBoxTy@@ -632,7 +539,7 @@   = newNonTrivialOverloadedLit orig lit res_ty   where     orig = LiteralOrigin lit-newOverloadedLit XOverLit{} _ = panic "newOverloadedLit"+newOverloadedLit (XOverLit nec) _ = noExtCon nec  -- Does not handle things that 'shortCutLit' can handle. See also -- newOverloadedLit in TcUnify@@ -664,7 +571,7 @@  mkOverLit (HsFractional r)   = do  { rat_ty <- tcMetaTy rationalTyConName-        ; return (HsRat noExt r rat_ty) }+        ; return (HsRat noExtField r rat_ty) }  mkOverLit (HsIsString src s) = return (HsString src s) @@ -706,11 +613,11 @@              -> TcM (Name, HsExpr GhcTcId)                                        -- ^ (Standard name, suitable expression) -- USED ONLY FOR CmdTop (sigh) ***--- See Note [CmdSyntaxTable] in HsExpr+-- See Note [CmdSyntaxTable] in GHC.Hs.Expr  tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm))   | std_nm == user_nm-  = do rhs <- newMethodFromName orig std_nm ty+  = do rhs <- newMethodFromName orig std_nm [ty]        return (std_nm, rhs)  tcSyntaxName orig ty (std_nm, user_nm_expr) = do
compiler/typecheck/TcAnnotations.hs view
@@ -18,7 +18,7 @@ import DynFlags import Control.Monad ( when ) -import HsSyn+import GHC.Hs import Name import Annotations import TcRnMonad@@ -28,7 +28,7 @@ -- Some platforms don't support the external interpreter, and -- compilation on those platforms shouldn't fail just due to -- annotations-#ifndef GHCI+#if !defined(HAVE_INTERNAL_INTERPRETER) tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation] tcAnnotations anns = do   dflags <- getDynFlags@@ -36,7 +36,7 @@     True  -> tcAnnotations' anns     False -> warnAnns anns warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation]---- No GHCI; emit a warning (not an error) and ignore. cf Trac #4268+--- No GHCI; emit a warning (not an error) and ignore. cf #4268 warnAnns [] = return [] warnAnns anns@(L loc _ : _)   = do { setSrcSpan loc $ addWarnTc NoReason $@@ -65,8 +65,8 @@       runAnnotation target expr     where       safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell."-                  , text "See https://ghc.haskell.org/trac/ghc/ticket/10826" ]-tcAnnotation (L _ (XAnnDecl _)) = panic "tcAnnotation"+                  , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ]+tcAnnotation (L _ (XAnnDecl nec)) = noExtCon nec  annProvenanceToTarget :: Module -> AnnProvenance Name                       -> AnnTarget Name@@ -74,6 +74,6 @@ annProvenanceToTarget _   (TypeAnnProvenance (L _ name))  = NamedTarget name annProvenanceToTarget mod ModuleAnnProvenance             = ModuleTarget mod -annCtxt :: (OutputableBndrId (GhcPass p)) => AnnDecl (GhcPass p) -> SDoc+annCtxt :: (OutputableBndrId p) => AnnDecl (GhcPass p) -> SDoc annCtxt ann   = hang (text "In the annotation:") 2 (ppr ann)
compiler/typecheck/TcArrows.hs view
@@ -14,7 +14,7 @@  import {-# SOURCE #-}   TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr ) -import HsSyn+import GHC.Hs import TcMatches import TcHsSyn( hsLPatType ) import TcType@@ -24,6 +24,7 @@ import TcUnify import TcRnMonad import TcEnv+import TcOrigin import TcEvidence import Id( mkLocalId ) import Inst@@ -126,7 +127,7 @@     do  { cmd'   <- tcCmd env cmd cmd_ty         ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names         ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names') cmd') }-tcCmdTop _ (L _ XCmdTop{}) _ = panic "tcCmdTop"+tcCmdTop _ (L _ (XCmdTop nec)) _ = noExtCon nec  ---------------------------------------- tcCmd  :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTcId)@@ -254,7 +255,7 @@                              tcPats LambdaExpr pats (map mkCheckExpType arg_tys) $                              tc_grhss grhss cmd_stk' (mkCheckExpType res_ty) -        ; let match' = L mtch_loc (Match { m_ext = noExt+        ; let match' = L mtch_loc (Match { m_ext = noExtField                                          , m_ctxt = LambdaExpr, m_pats = pats'                                          , m_grhss = grhss' })               arg_tys = map hsLPatType pats'@@ -271,14 +272,14 @@         = do { (binds', grhss') <- tcLocalBinds binds $                                    mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss              ; return (GRHSs x grhss' (L l binds')) }-    tc_grhss (XGRHSs _) _ _ = panic "tc_grhss"+    tc_grhss (XGRHSs nec) _ _ = noExtCon nec      tc_grhs stk_ty res_ty (GRHS x guards body)         = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $                                   \ res_ty -> tcCmd env body                                                 (stk_ty, checkingExpType "tc_grhs" res_ty)              ; return (GRHS x guards' rhs') }-    tc_grhs _ _ (XGRHS _) = panic "tc_grhs"+    tc_grhs _ _ (XGRHS nec) = noExtCon nec  ------------------------------------------- --              Do notation@@ -308,7 +309,7 @@     do  { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args                               -- We use alphaTyVar for 'w'         ; let e_ty = mkInvForAllTy alphaTyVar $-                     mkFunTys cmd_tys $+                     mkVisFunTys cmd_tys $                      mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty         ; expr' <- tcPolyExpr expr e_ty         ; return (HsCmdArrForm x expr' f fixity cmd_args') }@@ -323,7 +324,7 @@             ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty)             ; return (cmd',  mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) } -tc_cmd _ (XCmd {}) _ = panic "tc_cmd"+tc_cmd _ (XCmd nec) _ = noExtCon nec  ----------------------------------------------------------------- --              Base case for illegal commands@@ -388,7 +389,7 @@                 -- NB:  The rec_ids for the recursive things                 --      already scope over this part. This binding may shadow                 --      some of them with polymorphic things with the same Name-                --      (see note [RecStmt] in HsExpr)+                --      (see note [RecStmt] in GHC.Hs.Expr)          ; let rec_ids = takeList rec_names tup_ids         ; later_ids <- tcLookupLocalIds later_names@@ -426,7 +427,7 @@ mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2]  arrowTyConKind :: Kind          --  *->*->*-arrowTyConKind = mkFunTys [liftedTypeKind, liftedTypeKind] liftedTypeKind+arrowTyConKind = mkVisFunTys [liftedTypeKind, liftedTypeKind] liftedTypeKind  {- ************************************************************************
compiler/typecheck/TcBackpack.hs view
@@ -19,11 +19,11 @@  import GhcPrelude -import BasicTypes (defaultFixity)+import BasicTypes (defaultFixity, TypeOrKind(..)) import Packages import TcRnExports import DynFlags-import HsSyn+import GHC.Hs import RdrName import TcRnMonad import TcTyDecls@@ -34,6 +34,8 @@ import TcMType import TcType import TcSimplify+import Constraint+import TcOrigin import LoadIface import RnNames import ErrUtils@@ -69,7 +71,7 @@  import {-# SOURCE #-} TcRnDriver -#include "GhclibHsVersions.h"+#include "HsVersions.h"  fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc fixityMisMatch real_thing real_fixity sig_fixity =@@ -91,7 +93,7 @@     -- implementation cases.     checkBootDeclM False sig_thing real_thing     real_fixity <- lookupFixityRn name-    let sig_fixity = case mi_fix_fn sig_iface (occName name) of+    let sig_fixity = case mi_fix_fn (mi_final_exts sig_iface) (occName name) of                         Nothing -> defaultFixity                         Just f -> f     when (real_fixity /= sig_fixity) $@@ -329,7 +331,7 @@     HscEnv -> UnitId ->     IO (Messages, Maybe ()) tcRnCheckUnitId hsc_env uid =-   withTiming (pure dflags)+   withTiming dflags               (text "Check unit id" <+> ppr uid)               (const ()) $    initTc hsc_env@@ -349,7 +351,7 @@ tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface                     -> IO (Messages, Maybe TcGblEnv) tcRnMergeSignatures hsc_env hpm orig_tcg_env iface =-  withTiming (pure dflags)+  withTiming dflags              (text "Signature merging" <+> brackets (ppr this_mod))              (const ()) $   initTc hsc_env HsigFile False this_mod real_loc $@@ -832,7 +834,7 @@             -- This is a HACK to prevent calculateAvails from including imp_mod             -- in the listing.  We don't want it because a module is NOT             -- supposed to include itself in its dep_orphs/dep_finsts.  See #13214-            iface' = iface { mi_orphan = False, mi_finsts = False }+            iface' = iface { mi_final_exts = (mi_final_exts iface){ mi_orphan = False, mi_finsts = False } }             avails = plusImportAvails (tcg_imports tcg_env) $                         calculateAvails dflags iface' False False ImportedBySystem         return tcg_env {@@ -843,7 +845,7 @@                 if outer_mod == mi_module iface                     -- Don't add ourselves!                     then tcg_merged tcg_env-                    else (mi_module iface, mi_mod_hash iface) : tcg_merged tcg_env+                    else (mi_module iface, mi_mod_hash (mi_final_exts iface)) : tcg_merged tcg_env             }      -- Note [Signature merging DFuns]@@ -878,7 +880,7 @@     HscEnv -> Module -> RealSrcSpan ->     IO (Messages, Maybe TcGblEnv) tcRnInstantiateSignature hsc_env this_mod real_loc =-   withTiming (pure dflags)+   withTiming dflags               (text "Signature instantiation"<+>brackets (ppr this_mod))               (const ()) $    initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature
compiler/typecheck/TcBinds.hs view
@@ -12,7 +12,6 @@  module TcBinds ( tcLocalBinds, tcTopBinds, tcValBinds,                  tcHsBootSigs, tcPolyCheck,-                 addTypecheckedBinds,                  chooseInferredQuantifiers,                  badBootDeclErr ) where @@ -25,10 +24,10 @@ import CostCentre (mkUserCC, CCFlavour(DeclCC)) import DynFlags import FastString-import HsSyn-import HscTypes( isHsBootOrSig )+import GHC.Hs import TcSigs import TcRnMonad+import TcOrigin import TcEnv import TcUnify import TcSimplify@@ -67,23 +66,9 @@ import ConLike  import Control.Monad--#include "GhclibHsVersions.h"--{- *********************************************************************-*                                                                      *-               A useful helper function-*                                                                      *-********************************************************************* -}+import Data.Foldable (find) -addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv-addTypecheckedBinds tcg_env binds-  | isHsBootOrSig (tcg_src tcg_env) = tcg_env-    -- Do not add the code for record-selector bindings-    -- when compiling hs-boot files-  | otherwise = tcg_env { tcg_binds = foldr unionBags-                                            (tcg_binds tcg_env)-                                            binds }+#include "HsVersions.h"  {- ************************************************************************@@ -256,7 +241,11 @@            mkMatch :: [ConLike] -> TyCon -> CompleteMatch           mkMatch cls ty_con = CompleteMatch {-            completeMatchConLikes = map conLikeName cls,+            -- foldM is a left-fold and will have accumulated the ConLikes in+            -- the reverse order. foldrM would accumulate in the correct order,+            -- but would type-check the last ConLike first, which might also be+            -- confusing from the user's perspective. Hence reverse here.+            completeMatchConLikes = reverse (map conLikeName cls),             completeMatchTyCon = tyConName ty_con             }       doOne _ = return Nothing@@ -302,7 +291,10 @@                   <+> parens (quotes (ppr tc)                                <+> text "resp."                                <+> quotes (ppr tc'))-  in  mapMaybeM (addLocM doOne) sigs+  -- For some reason I haven't investigated further, the signatures come in+  -- backwards wrt. declaration order. So we reverse them here, because it makes+  -- a difference for incomplete match suggestions.+  in  mapMaybeM (addLocM doOne) (reverse sigs) -- process in declaration order  tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id] -- A hs-boot file has only one BindGroup, and it only has type@@ -359,17 +351,17 @@             ; ip_id <- newDict ipClass [ p, ty ]             ; expr' <- tcMonoExpr expr (mkCheckExpType ty)             ; let d = toDict ipClass p ty `fmap` expr'-            ; return (ip_id, (IPBind noExt (Right ip_id) d)) }+            ; return (ip_id, (IPBind noExtField (Right ip_id) d)) }     tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind"-    tc_ip_bind _ (XIPBind _) = panic "tc_ip_bind"+    tc_ip_bind _ (XIPBind nec) = noExtCon nec      -- Coerces a `t` into a dictionry for `IP "x" t`.     -- co : t -> IP "x" t     toDict ipClass x ty = mkHsWrap $ mkWpCastR $                           wrapIP $ mkClassPred ipClass [x,ty] -tcLocalBinds (HsIPBinds _ (XHsIPBinds _ )) _ = panic "tcLocalBinds"-tcLocalBinds (XHsLocalBindsLR _)           _ = panic "tcLocalBinds"+tcLocalBinds (HsIPBinds _ (XHsIPBinds nec)) _ = noExtCon nec+tcLocalBinds (XHsLocalBindsLR nec)          _ = noExtCon nec  {- Note [Implicit parameter untouchables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -485,12 +477,13 @@         -- (This used to be optional, but isn't now.)         -- See Note [Polymorphic recursion] in HsBinds.     do  { traceTc "tc_group rec" (pprLHsBinds binds)-        ; when hasPatSyn $ recursivePatSynErr binds+        ; whenIsJust mbFirstPatSyn $ \lpat_syn ->+            recursivePatSynErr (getLoc lpat_syn) binds         ; (binds1, thing) <- go sccs         ; return ([(Recursive, binds1)], thing) }                 -- Rec them all together   where-    hasPatSyn = anyBag (isPatSyn . unLoc) binds+    mbFirstPatSyn = find (isPatSyn . unLoc) binds     isPatSyn PatSynBind{} = True     isPatSyn _ = False @@ -511,10 +504,14 @@     tc_sub_group rec_tc binds =       tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds -recursivePatSynErr :: OutputableBndrId (GhcPass p) =>-                      LHsBinds (GhcPass p) -> TcM a-recursivePatSynErr binds-  = failWithTc $+recursivePatSynErr ::+     OutputableBndrId p =>+     SrcSpan -- ^ The location of the first pattern synonym binding+             --   (for error reporting)+  -> LHsBinds (GhcPass p)+  -> TcM a+recursivePatSynErr loc binds+  = failAt loc $     hang (text "Recursive pattern synonym definition with following bindings:")        2 (vcat $ map pprLBind . bagToList $ binds)   where@@ -639,7 +636,7 @@ -- Another alternative would be (forall (a :: TYPE kappa). a), where -- kappa is a unification variable. But I don't think we need that -- complication here. I'm going to just use (forall (a::*). a).--- See Trac #15276+-- See #15276 forall_a_a = mkSpecForAllTys [alphaTyVar] alphaTy  {- *********************************************************************@@ -720,14 +717,14 @@                              , fun_ext     = placeHolderNamesTc                              , fun_tick    = tick } -             export = ABE { abe_ext = noExt-                          , abe_wrap = idHsWrapper+             export = ABE { abe_ext   = noExtField+                          , abe_wrap  = idHsWrapper                           , abe_poly  = poly_id                           , abe_mono  = mono_id                           , abe_prags = SpecPrags spec_prags }               abs_bind = cL loc $-                        AbsBinds { abs_ext = noExt+                        AbsBinds { abs_ext      = noExtField                                  , abs_tvs      = skol_tvs                                  , abs_ev_vars  = ev_vars                                  , abs_ev_binds = [ev_binds]@@ -810,7 +807,7 @@        ; loc <- getSrcSpanM        ; let poly_ids = map abe_poly exports              abs_bind = cL loc $-                        AbsBinds { abs_ext = noExt+                        AbsBinds { abs_ext = noExtField                                  , abs_tvs = qtvs                                  , abs_ev_vars = givens, abs_ev_binds = [ev_binds]                                  , abs_exports = exports, abs_binds = binds'@@ -871,7 +868,7 @@         ; when warn_missing_sigs $               localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig -        ; return (ABE { abe_ext = noExt+        ; return (ABE { abe_ext = noExtField                       , abe_wrap = wrap                         -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)                       , abe_poly  = poly_id@@ -919,7 +916,7 @@          checkValidType (InfSigCtxt poly_name) inferred_poly_ty          -- See Note [Validity of inferred types]          -- If we found an insoluble error in the function definition, don't-         -- do this check; otherwise (Trac #14000) we may report an ambiguity+         -- do this check; otherwise (#14000) we may report an ambiguity          -- error for a rather bogus type.         ; return (mkLocalIdOrCoVar poly_name inferred_poly_ty) }@@ -933,7 +930,7 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing   = -- No type signature (partial or complete) for this binder,     do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs)-                        -- Include kind variables!  Trac #7916+                        -- Include kind variables!  #7916              my_theta = pickCapturedPreds free_tvs inferred_theta              binders  = [ mkTyVarBinder Inferred tv                         | tv <- qtvs@@ -1020,7 +1017,7 @@             ; case tcGetCastedTyVar_maybe wc_var_ty of                -- We know that wc_co must have type kind(wc_var) ~ Constraint, as it-               -- comes from the checkExpectedKind in TcHsType.tcWildCardOcc. So, to+               -- comes from the checkExpectedKind in TcHsType.tcAnonWildCardOcc. So, to                -- make the kinds work out, we reverse the cast here.                Just (wc_var, wc_co) -> writeMetaTyVar wc_var (ctuple `mkCastTy` mkTcSymCo wc_co)                Nothing              -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty)@@ -1087,7 +1084,7 @@ --   K f = e -- The MR applies, but the signature is overloaded, and it's -- best to complain about this directly--- c.f Trac #11339+-- c.f #11339 checkOverloadedSig monomorphism_restriction_applies sig   | not (null (sig_inst_theta sig))   , monomorphism_restriction_applies@@ -1125,7 +1122,7 @@ way to get per-binding inferred generalisation.  We apply the MR if /all/ of the partial signatures lack a context.-In particular (Trac #11016):+In particular (#11016):    f2 :: (?loc :: Int) => _    f2 = ?loc It's stupid to apply the MR here.  This test includes an extra-constraints@@ -1151,7 +1148,7 @@ We want to get an error from this, because 'a' and 'b' get unified. So we make a test, one per parital signature, to check that the explicitly-quantified type variables have not been unified together.-Trac #14449 showed this up.+#14449 showed this up.   Note [Validity of inferred types]@@ -1201,7 +1198,7 @@      forall qtvs. theta => f_mono_ty   is more polymorphic than   f's polytype and the proof is the impedance matcher. -Notice that the impedance matcher may do defaulting.  See Trac #7173.+Notice that the impedance matcher may do defaulting.  See #7173.  It also cleverly does an ambiguity check; for example, rejecting    f :: F a -> F a@@ -1269,7 +1266,7 @@     do  { ((co_fn, matches'), rhs_ty)             <- tcInferInst $ \ exp_ty ->                   -- tcInferInst: see TcUnify,-                  -- Note [Deep instantiation of InferResult]+                  -- Note [Deep instantiation of InferResult] in TcUnify                tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $                   -- We extend the error context even for a non-recursive                   -- function so that in type error messages we show the@@ -1488,7 +1485,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Look at:    - typecheck/should_compile/ExPat-   - Trac #12427, typecheck/should_compile/T12427{a,b}+   - #12427, typecheck/should_compile/T12427{a,b}    data T where     MkT :: Integral a => a -> Int -> T@@ -1567,7 +1564,7 @@        CheckGen), then the let_bndr_spec will be LetLclBndr.  In that case        we want to bind a cloned, local version of the variable, with the        type given by the pattern context, *not* by the signature (even if-       there is one; see Trac #7268). The mkExport part of the+       there is one; see #7268). The mkExport part of the        generalisation step will do the checking and impedance matching        against the signature. @@ -1589,7 +1586,7 @@  Example for (E2), we generate      q :: beta:1, with constraint (forall:3 a. Integral a => Int ~ beta)-The beta is untoucable, but floats out of the constraint and can+The beta is untouchable, but floats out of the constraint and can be solved absolutely fine.  @@ -1637,7 +1634,7 @@       = [ null theta         | TcIdSig (PartialSig { psig_hs_ty = hs_ty })             <- mapMaybe sig_fn (collectHsBindListBinders lbinds)-        , let (_, dL->L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ]+        , let (_, dL->L _ theta, _) = splitLHsSigmaTyInvis (hsSigWcType hs_ty) ]      has_partial_sigs   = not (null partial_sig_mrs) @@ -1732,7 +1729,7 @@  -- This one is called on LHS, when pat and grhss are both Name -- and on RHS, when pat is TcId and grhss is still Name-patMonoBindsCtxt :: (OutputableBndrId (GhcPass p), Outputable body)+patMonoBindsCtxt :: (OutputableBndrId p, Outputable body)                  => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc patMonoBindsCtxt pat grhss   = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)
compiler/typecheck/TcCanonical.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}  module TcCanonical(      canonicalize,@@ -8,11 +9,13 @@      solveCallStack    -- For TcSimplify   ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude -import TcRnTypes+import Constraint+import Predicate+import TcOrigin import TcUnify( swapOverTyVars, metaTyVarUpdateOK ) import TcType import Type@@ -35,7 +38,7 @@ import DynFlags( DynFlags ) import NameSet import RdrName-import HsTypes( HsIPName(..) )+import GHC.Hs.Types( HsIPName(..) )  import Pair import Util@@ -47,6 +50,7 @@ import BasicTypes  import Data.Bifunctor ( bimap )+import Data.Foldable ( traverse_ )  {- ************************************************************************@@ -102,7 +106,7 @@ canonicalize (CIrredCan { cc_ev = ev })   | EqPred eq_rel ty1 ty2 <- classifyPredType (ctEvPred ev)   = -- For insolubles (all of which are equalities, do /not/ flatten the arguments-    -- In Trac #14350 doing so led entire-unnecessary and ridiculously large+    -- In #14350 doing so led entire-unnecessary and ridiculously large     -- type function expansion.  Instead, canEqNC just applies     -- the substitution to the predicate, and may do decomposition;     --    e.g. a ~ [a], where [G] a ~ [Int], can decompose@@ -248,7 +252,7 @@   is a waste of time.  * (Major) if we want recursive superclasses, there would be an infinite-  number of them.  Here is a real-life example (Trac #10318);+  number of them.  Here is a real-life example (#10318);       class (Frac (Frac a) ~ Frac a,             Fractional (Frac a),@@ -275,13 +279,13 @@    solveSimpleWanteds; Note [Danger of adding superclasses during solving]     However, /do/ continue to eagerly expand superlasses for new /given/-   /non-canonical/ constraints (canClassNC does this).  As Trac #12175+   /non-canonical/ constraints (canClassNC does this).  As #12175    showed, a type-family application can expand to a class constraint,    and we want to see its superclasses for just the same reason as    Note [Eagerly expand given superclasses].  3. If we have any remaining unsolved wanteds-        (see Note [When superclasses help] in TcRnTypes)+        (see Note [When superclasses help] in Constraint)    try harder: take both the Givens and Wanteds, and expand    superclasses again.  See the calls to expandSuperClasses in    TcSimplify.simpl_loop and solveWanteds.@@ -296,7 +300,7 @@         of the implication tree       - We may be inside a type where we can't create term-level         evidence anyway, so we can't superclass-expand, say,-        (a ~ b) to get (a ~# b).  This happened in Trac #15290.+        (a ~ b) to get (a ~# b).  This happened in #15290.  4. Go round to (2) again.  This loop (2,3,4) is implemented    in TcSimplify.simpl_loop.@@ -409,7 +413,7 @@  Note [Danger of adding superclasses during solving] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Here's a serious, but now out-dated example, from Trac #4497:+Here's a serious, but now out-dated example, from #4497:     class Num (RealOf t) => Normed t    type family RealOf x@@ -509,7 +513,7 @@        = loc   -- For tuple predicates, just take them apart, without                -- adding their (large) size into the chain.  When we                -- get down to a base predicate, we'll include its size.-               -- Trac #10335+               -- #10335         | GivenOrigin skol_info <- ctLocOrigin loc          -- See Note [Solving superclass constraints] in TcInstDcls@@ -582,7 +586,7 @@  {- Note [Equality superclasses in quantified constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (Trac #15359, #15593, #15625)+Consider (#15359, #15593, #15625)   f :: (forall a. theta => a ~ b) => stuff  It's a bit odd to have a local, quantified constraint for `(a~b)`,@@ -614,7 +618,7 @@ which looks for primitive equalities specially in the quantified constraints. -See also Note [Evidence for quantified constraints] in Type.+See also Note [Evidence for quantified constraints] in Predicate.   ************************************************************************@@ -670,7 +674,7 @@ constraint which arises form the (==) definition.  The wiki page is-  https://ghc.haskell.org/trac/ghc/wiki/QuantifiedConstraints+  https://gitlab.haskell.org/ghc/ghc/wikis/quantified-constraints which in turn contains a link to the GHC Proposal where the change is specified, and a Haskell Symposium paper about it. @@ -698,7 +702,7 @@   * checkValidType gets some changes to accept forall-constraints     only in the right places. -  * Type.PredTree gets a new constructor ForAllPred, and+  * Predicate.Pred gets a new constructor ForAllPred, and     and classifyPredType analyses a PredType to decompose     the new forall-constraints @@ -824,7 +828,6 @@  Note [FunTy and decomposing tycon applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- When can_eq_nc' attempts to decompose a tycon application we haven't yet zonked. This means that we may very well have a FunTy containing a type of some unknown kind. For instance, we may have,@@ -873,9 +876,9 @@    -> TcS (StopOrContinue Ct)  -- Expand synonyms first; see Note [Type synonyms and canonicalization]-can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2-  | Just ty1' <- tcView ty1 = can_eq_nc flat ev eq_rel ty1' ps_ty1 ty2  ps_ty2-  | Just ty2' <- tcView ty2 = can_eq_nc flat ev eq_rel ty1  ps_ty1 ty2' ps_ty2+can_eq_nc' flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2+  | Just ty1' <- tcView ty1 = can_eq_nc' flat rdr_env envs ev eq_rel ty1' ps_ty1 ty2  ps_ty2+  | Just ty2' <- tcView ty2 = can_eq_nc' flat rdr_env envs ev eq_rel ty1  ps_ty1 ty2' ps_ty2  -- need to check for reflexivity in the ReprEq case. -- See Note [Eager reflexivity check]@@ -923,8 +926,8 @@ -- Including FunTy (s -> t) can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1 _ ty2 _     --- See Note [FunTy and decomposing type constructor applications].-  | Just (tc1, tys1) <- tcRepSplitTyConApp_maybe' ty1-  , Just (tc2, tys2) <- tcRepSplitTyConApp_maybe' ty2+  | Just (tc1, tys1) <- repSplitTyConApp_maybe ty1+  , Just (tc2, tys2) <- repSplitTyConApp_maybe ty2   , not (isTypeFamilyTyCon tc1)   , not (isTypeFamilyTyCon tc2)   = canTyConApp ev eq_rel tc1 tys1 tc2 tys2@@ -965,7 +968,7 @@   (a b ~R# Int) that is not necessarily insoluble!  Maybe 'a' will turn out to be a newtype. So we want to make it a potentially-soluble Irred not an insoluble one.-Missing this point is what caused Trac #15431+Missing this point is what caused #15431 -}  ---------------------------------@@ -978,7 +981,7 @@ -- But remember also to unify the kinds of as and bs --  (this is the 'go' loop), and actually substitute phi2[as |> cos / bs] -- Remember also that we might have forall z (a:z). blah---  so we must proceed one binder at a time (Trac #13879)+--  so we must proceed one binder at a time (#13879)  can_eq_nc_forall ev eq_rel s1 s2  | CtWanted { ctev_loc = loc, ctev_dest = orig_dest } <- ev@@ -1007,8 +1010,10 @@               = do { let tv2 = binderVar bndr2                    ; (kind_co, wanteds1) <- unify loc Nominal (tyVarKind skol_tv)                                                   (substTy subst (tyVarKind tv2))-                   ; let subst' = extendTvSubst subst tv2+                   ; let subst' = extendTvSubstAndInScope subst tv2                                        (mkCastTy (mkTyVarTy skol_tv) kind_co)+                         -- skol_tv is already in the in-scope set, but the+                         -- free vars of kind_co are not; hence "...AndInScope"                    ; (co, wanteds2) <- go skol_tvs subst' bndrs2                    ; return ( mkTcForAllCo skol_tv kind_co co                             , wanteds1 `unionBags` wanteds2 ) }@@ -1016,7 +1021,7 @@             -- Done: unify phi1 ~ phi2             go [] subst bndrs2               = ASSERT( null bndrs2 )-                unify loc (eqRelRole eq_rel) phi1' (substTy subst phi2)+                unify loc (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2)              go _ _ _ = panic "cna_eq_nc_forall"  -- case (s:ss) [] @@ -1048,7 +1053,7 @@ -- | Compare types for equality, while zonking as necessary. Gives up -- as soon as it finds that two types are not equal. -- This is quite handy when some unification has made two--- types in an inert wanted to be equal. We can discover the equality without+-- types in an inert Wanted to be equal. We can discover the equality without -- flattening, which is sometimes very expensive (in the case of type functions). -- In particular, this function makes a ~20% improvement in test case -- perf/compiler/T5030.@@ -1080,7 +1085,7 @@       , Just (arg2, res2) <- split2       = do { res_a <- go arg1 arg2            ; res_b <- go res1 res2-           ; return $ combine_rev mkFunTy res_b res_a+           ; return $ combine_rev mkVisFunTy res_b res_a            }       | isJust split1 || isJust split2       = bale_out ty1 ty2@@ -1089,15 +1094,15 @@         split2 = tcSplitFunTy_maybe ty2      go ty1 ty2-      | Just (tc1, tys1) <- tcRepSplitTyConApp_maybe ty1-      , Just (tc2, tys2) <- tcRepSplitTyConApp_maybe ty2+      | Just (tc1, tys1) <- repSplitTyConApp_maybe ty1+      , Just (tc2, tys2) <- repSplitTyConApp_maybe ty2       = if tc1 == tc2 && tys1 `equalLength` tys2           -- Crucial to check for equal-length args, because           -- we cannot assume that the two args to 'go' have           -- the same kind.  E.g go (Proxy *      (Maybe Int))           --                        (Proxy (*->*) Maybe)           -- We'll call (go (Maybe Int) Maybe)-          -- See Trac #13083+          -- See #13083         then tycon tc1 tys1 tys2         else bale_out ty1 ty2 @@ -1199,7 +1204,7 @@ which is easier to satisfy.  Bottom line: unwrap newtypes before decomposing them!-c.f. Trac #9123 comment:52,53 for a compelling example.+c.f. #9123 comment:52,53 for a compelling example.  Note [Newtypes can blow the stack] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1265,13 +1270,22 @@          -- check for blowing our stack:          -- See Note [Newtypes can blow the stack]        ; checkReductionDepth (ctEvLoc ev) ty1-       ; addUsedGREs (bagToList gres)-           -- we have actually used the newtype constructor here, so-           -- make sure we don't warn about importing it! +         -- Next, we record uses of newtype constructors, since coercing+         -- through newtypes is tantamount to using their constructors.+       ; addUsedGREs gre_list+         -- If a newtype constructor was imported, don't warn about not+         -- importing it...+       ; traverse_ keepAlive $ map gre_name gre_list+         -- ...and similarly, if a newtype constructor was defined in the same+         -- module, don't warn about it being unused.+         -- See Note [Tracking unused binding and imports] in TcRnTypes.+        ; new_ev <- rewriteEqEvidence ev swapped ty1' ps_ty2                                      (mkTcSymCo co) (mkTcReflCo Representational ps_ty2)        ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 }+  where+    gre_list = bagToList gres  --------- -- ^ Decompose a type application.@@ -1286,10 +1300,10 @@ -- to an irreducible constraint; see typecheck/should_compile/T10494 -- See Note [Decomposing equality], note {4} can_eq_app ev s1 t1 s2 t2-  | CtDerived { ctev_loc = loc } <- ev+  | CtDerived {} <- ev   = do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2]        ; stopWith ev "Decomposed [D] AppTy" }-  | CtWanted { ctev_dest = dest, ctev_loc = loc } <- ev+  | CtWanted { ctev_dest = dest } <- ev   = do { co_s <- unifyWanted loc Nominal s1 s2        ; let arg_loc                | isNextArgVisible s1 = loc@@ -1307,7 +1321,7 @@   | s1k `mismatches` s2k   = canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2) -  | CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev+  | CtGiven { ctev_evar = evar } <- ev   = do { let co   = mkTcCoVarCo evar              co_s = mkTcLRCo CLeft  co              co_t = mkTcLRCo CRight co@@ -1319,6 +1333,8 @@        ; canEqNC evar_s NomEq s1 s2 }    where+    loc = ctEvLoc ev+     s1k = tcTypeKind s1     s2k = tcTypeKind s2 @@ -1569,6 +1585,7 @@ Conclusion:   * Decompose [W] N s ~R N t  iff there no given constraint that could     later solve it.+ -}  canDecomposableTyConAppOK :: CtEvidence -> EqRel@@ -1769,7 +1786,7 @@  We use `isTcReflexiveCo`, to ensure that we only use the hetero-kinded case if we really need to.  Of course `flattenArgsNom` should return `Refl`-whenever possible, but Trac #15577 was an infinite loop because even+whenever possible, but #15577 was an infinite loop because even though the coercion was homo-kinded, `kind_co` was not `Refl`, so we made a new (identical) CFunEqCan, and then the entire process repeated. -}@@ -1832,14 +1849,15 @@            -> TcType                -- lhs: pretty lhs, already flat            -> TcType -> TcType      -- rhs: already flat            -> TcS (StopOrContinue Ct)-canEqTyVar ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2+canEqTyVar ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2   | k1 `tcEqType` k2-  = canEqTyVarHomo ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2+  = canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2 -         -- Note [Flattening] in TcFlatten gives us (F2), which says that-         -- flattening is always homogeneous (doesn't change kinds). But-         -- perhaps by flattening the kinds of the two sides of the equality-         -- at hand makes them equal. So let's try that.+  -- So the LHS and RHS don't have equal kinds+  -- Note [Flattening] in TcFlatten gives us (F2), which says that+  -- flattening is always homogeneous (doesn't change kinds). But+  -- perhaps by flattening the kinds of the two sides of the equality+  -- at hand makes them equal. So let's try that.   | otherwise   = do { (flat_k1, k1_co) <- flattenKind loc flav k1  -- k1_co :: flat_k1 ~N kind(xi1)        ; (flat_k2, k2_co) <- flattenKind loc flav k2  -- k2_co :: flat_k2 ~N kind(xi2)@@ -1852,7 +1870,7 @@                         , ppr flat_k2                         , ppr k2_co ]) -         -- we know the LHS is a tyvar. So let's dump all the coercions on the RHS+         -- We know the LHS is a tyvar. So let's dump all the coercions on the RHS          -- If flat_k1 == flat_k2, let's dump all the coercions on the RHS and          -- then call canEqTyVarHomo. If they don't equal, just rewriteEqEvidence          -- (as an optimization, so that we don't have to flatten the kinds again)@@ -1872,7 +1890,7 @@                                                (mkTcReflCo role xi1) rhs_co                        -- NB: rewriteEqEvidence executes a swap, if any, so we're                        -- NotSwapped now.-                 ; canEqTyVarHomo new_ev eq_rel NotSwapped tv1 ps_ty1 new_rhs ps_rhs }+                 ; canEqTyVarHomo new_ev eq_rel NotSwapped tv1 ps_xi1 new_rhs ps_rhs }          else     do { let sym_k1_co = mkTcSymCo k1_co  -- :: kind(xi1) ~N flat_k1              sym_k2_co = mkTcSymCo k2_co  -- :: kind(xi2) ~N flat_k2@@ -1888,7 +1906,7 @@         ; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co          -- no longer swapped, due to rewriteEqEvidence-       ; canEqTyVarHetero new_ev eq_rel tv1 sym_k1_co flat_k1 ps_ty1+       ; canEqTyVarHetero new_ev eq_rel tv1 sym_k1_co flat_k1 ps_xi1                                         new_rhs flat_k2 ps_rhs } }   where     xi1 = mkTyVarTy tv1@@ -1934,7 +1952,7 @@    -- See Note [Equalities with incompatible kinds]   | otherwise   -- Wanted and Derived-                  -- NB: all kind equalities are Nominal+                -- NB: all kind equalities are Nominal   = do { emitNewDerivedEq kind_loc Nominal ki1 ki2              -- kind_ev :: (ki1 :: *) ~ (ki2 :: *)        ; traceTcS "Hetero equality gives rise to derived kind equality" $@@ -1952,16 +1970,16 @@ canEqTyVarHomo :: CtEvidence                -> EqRel -> SwapFlag                -> TcTyVar                -- lhs: tv1-               -> TcType                 -- pretty lhs-               -> TcType -> TcType       -- rhs (might not be flat)+               -> TcType                 -- pretty lhs, flat+               -> TcType -> TcType       -- rhs, flat                -> TcS (StopOrContinue Ct)-canEqTyVarHomo ev eq_rel swapped tv1 ps_ty1 ty2 _-  | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2+canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 _+  | Just (tv2, _) <- tcGetCastedTyVar_maybe xi2   , tv1 == tv2   = canEqReflexive ev eq_rel (mkTyVarTy tv1)     -- we don't need to check co because it must be reflexive -  | Just (tv2, co2) <- tcGetCastedTyVar_maybe ty2+  | Just (tv2, co2) <- tcGetCastedTyVar_maybe xi2   , swapOverTyVars tv1 tv2   = do { traceTcS "canEqTyVar swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped)          -- FM_Avoid commented out: see Note [Lazy flattening] in TcFlatten@@ -1981,11 +1999,11 @@        ; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co         ; dflags <- getDynFlags-       ; canEqTyVar2 dflags new_ev eq_rel IsSwapped tv2 (ps_ty1 `mkCastTy` sym_co2) }+       ; canEqTyVar2 dflags new_ev eq_rel IsSwapped tv2 (ps_xi1 `mkCastTy` sym_co2) } -canEqTyVarHomo ev eq_rel swapped tv1 _ _ ps_ty2+canEqTyVarHomo ev eq_rel swapped tv1 _ _ ps_xi2   = do { dflags <- getDynFlags-       ; canEqTyVar2 dflags ev eq_rel swapped tv1 ps_ty2 }+       ; canEqTyVar2 dflags ev eq_rel swapped tv1 ps_xi2 }  -- The RHS here is either not a casted tyvar, or it's a tyvar but we want -- to rewrite the LHS to the RHS (as per swapOverTyVars)@@ -1994,7 +2012,7 @@             -> EqRel             -> SwapFlag             -> TcTyVar                  -- lhs = tv, flat-            -> TcType                   -- rhs+            -> TcType                   -- rhs, flat             -> TcS (StopOrContinue Ct) -- LHS is an inert type variable, -- and RHS is fully rewritten, but with type synonyms@@ -2003,7 +2021,7 @@   | Just rhs' <- metaTyVarUpdateOK dflags tv1 rhs  -- No occurs check      -- Must do the occurs check even on tyvar/tyvar      -- equalities, in case have  x ~ (y :: ..x...)-     -- Trac #12593+     -- #12593   = do { new_ev <- rewriteEqEvidence ev swapped lhs rhs' rewrite_co1 rewrite_co2        ; continueWith (CTyEqCan { cc_ev = new_ev, cc_tyvar = tv1                                 , cc_rhs = rhs', cc_eq_rel = eq_rel }) }@@ -2099,7 +2117,7 @@ is embarrassing. See #11198 for more tales of destruction.  The reason for this odd behavior is much the same as-Note [Wanteds do not rewrite Wanteds] in TcRnTypes: note that the+Note [Wanteds do not rewrite Wanteds] in Constraint: note that the new `co` is a Wanted.  The solution is then not to use `co` to "rewrite" -- that is, cast -- `w`, but@@ -2169,7 +2187,7 @@ application on one side and a variable on the other side, we should NOT (necessarily) expand the type synonym, since for the purpose of good error messages we want to leave type synonyms unexpanded as much-as possible.  Hence the ps_ty1, ps_ty2 argument passed to canEqTyVar.+as possible.  Hence the ps_xi1, ps_xi2 argument passed to canEqTyVar.  -} @@ -2188,10 +2206,7 @@   | Stop CtEvidence   -- The (rewritten) constraint was solved          SDoc         -- Tells how it was solved                       -- Any new sub-goals have been put on the work list--instance Functor StopOrContinue where-  fmap f (ContinueWith x) = ContinueWith (f x)-  fmap _ (Stop ev s)      = Stop ev s+  deriving (Functor)  instance Outputable a => Outputable (StopOrContinue a) where   ppr (Stop ev s)      = text "Stop" <> parens s <+> ppr ev@@ -2258,7 +2273,7 @@     -- Why?  Because for *Derived* constraints, c, the coercion, which     -- was produced by flattening, may contain suspended calls to     -- (ctEvExpr c), which fails for Derived constraints.-    -- (Getting this wrong caused Trac #7384.)+    -- (Getting this wrong caused #7384.)     continueWith (old_ev { ctev_pred = new_pred })  rewriteEvidence old_ev new_pred co@@ -2275,8 +2290,12 @@                                                        (mkTcSymCo co))  rewriteEvidence ev@(CtWanted { ctev_dest = dest+                             , ctev_nosh = si                              , ctev_loc = loc }) new_pred co-  = do { mb_new_ev <- newWanted loc new_pred+  = do { mb_new_ev <- newWanted_SI si loc new_pred+               -- The "_SI" varant ensures that we make a new Wanted+               -- with the same shadow-info as the existing one+               -- with the same shadow-info as the existing one (#16735)        ; MASSERT( tcCoercionRole co == ctEvRole ev )        ; setWantedEvTerm dest             (mkEvCast (getEvExpr mb_new_ev)@@ -2324,8 +2343,10 @@                                   `mkTcTransCo` mkTcSymCo rhs_co)        ; newGivenEvVar loc' (new_pred, new_tm) } -  | CtWanted { ctev_dest = dest } <- old_ev-  = do { (new_ev, hole_co) <- newWantedEq loc' (ctEvRole old_ev) nlhs nrhs+  | CtWanted { ctev_dest = dest, ctev_nosh = si } <- old_ev+  = do { (new_ev, hole_co) <- newWantedEq_SI si loc' (ctEvRole old_ev) nlhs nrhs+               -- The "_SI" varant ensures that we make a new Wanted+               -- with the same shadow-info as the existing one (#16735)        ; let co = maybeSym swapped $                   mkSymCo lhs_co                   `mkTransCo` hole_co@@ -2375,7 +2396,7 @@     go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2     go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' -    go (FunTy s1 t1) (FunTy s2 t2)+    go (FunTy _ s1 t1) (FunTy _ s2 t2)       = do { co_s <- unifyWanted loc role s1 s2            ; co_t <- unifyWanted loc role t1 t2            ; return (mkFunCo role co_s co_t) }@@ -2426,7 +2447,7 @@     go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2     go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' -    go (FunTy s1 t1) (FunTy s2 t2)+    go (FunTy _ s1 t1) (FunTy _ s2 t2)       = do { unify_derived loc role s1 s2            ; unify_derived loc role t1 t2 }     go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
compiler/typecheck/TcClassDcl.hs view
@@ -18,11 +18,11 @@                     tcATDefault                   ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude -import HsSyn+import GHC.Hs import TcEnv import TcSigs import TcEvidence ( idHsWrapper )@@ -30,7 +30,9 @@ import TcUnify import TcHsType import TcMType-import Type     ( getClassPredTys_maybe, piResultTys )+import Type     ( piResultTys )+import Predicate+import TcOrigin import TcType import TcRnMonad import DriverPhases (HscSource(..))@@ -284,12 +286,12 @@                   tcPolyCheck no_prag_fn local_dm_sig                               (L bind_loc lm_bind) -       ; let export = ABE { abe_ext   = noExt+       ; let export = ABE { abe_ext   = noExtField                           , abe_poly  = global_dm_id                           , abe_mono  = local_dm_id                           , abe_wrap  = idHsWrapper                           , abe_prags = IsDefaultMethod }-             full_bind = AbsBinds { abs_ext      = noExt+             full_bind = AbsBinds { abs_ext      = noExtField                                   , abs_tvs      = tyvars                                   , abs_ev_vars  = [this_dict]                                   , abs_exports  = [export]@@ -369,7 +371,7 @@                 -- site of the method binder, and any inline or                 -- specialisation pragmas findMethodBind sel_name binds prag_fn-  = foldlBag mplus Nothing (mapBag f binds)+  = foldl' mplus Nothing (mapBag f binds)   where     prags    = lookupPragEnv prag_fn sel_name
compiler/typecheck/TcDefaults.hs view
@@ -10,7 +10,7 @@  import GhcPrelude -import HsSyn+import GHC.Hs import Class import TcRnMonad import TcEnv@@ -66,7 +66,7 @@ tcDefaults decls@(L locn (DefaultDecl _ _) : _)   = setSrcSpan locn $     failWithTc (dupDefaultDeclErr decls)-tcDefaults (L _ (XDefaultDecl _):_) = panic "tcDefaults"+tcDefaults (L _ (XDefaultDecl nec):_) = noExtCon nec   tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type@@ -100,8 +100,8 @@   where     pp (L locn (DefaultDecl _ _))       = text "here was another default declaration" <+> ppr locn-    pp (L _ (XDefaultDecl _)) = panic "dupDefaultDeclErr"-dupDefaultDeclErr (L _ (XDefaultDecl _) : _) = panic "dupDefaultDeclErr"+    pp (L _ (XDefaultDecl nec)) = noExtCon nec+dupDefaultDeclErr (L _ (XDefaultDecl nec) : _) = noExtCon nec dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"  badDefaultTy :: Type -> [Class] -> SDoc
compiler/typecheck/TcDeriv.hs view
@@ -7,2225 +7,2282 @@ -}  {-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}--module TcDeriv ( tcDeriving, DerivInfo(..), mkDerivInfos ) where--#include "GhclibHsVersions.h"--import GhcPrelude--import HsSyn-import DynFlags--import TcRnMonad-import FamInst-import TcDerivInfer-import TcDerivUtils-import TcValidity( allDistinctTyVars )-import TcClassDcl( instDeclCtxt3, tcATDefault, tcMkDeclCtxt )-import TcEnv-import TcGenDeriv                       -- Deriv stuff-import TcValidity( checkValidInstHead )-import InstEnv-import Inst-import FamInstEnv-import TcHsType-import TyCoRep--import RnNames( extendGlobalRdrEnvRn )-import RnBinds-import RnEnv-import RnUtils    ( bindLocalNamesFV )-import RnSource   ( addTcgDUs )-import Avail--import Unify( tcUnifyTy )-import Class-import Type-import ErrUtils-import DataCon-import Maybes-import RdrName-import Name-import NameSet-import TyCon-import TcType-import Var-import VarEnv-import VarSet-import PrelNames-import SrcLoc-import Util-import Outputable-import FastString-import Bag-import Pair-import FV (fvVarList, unionFV, mkFVs)-import qualified GHC.LanguageExtensions as LangExt--import Control.Monad-import Control.Monad.Trans.Class-import Control.Monad.Trans.Reader-import Data.List--{--************************************************************************-*                                                                      *-                Overview-*                                                                      *-************************************************************************--Overall plan-~~~~~~~~~~~~-1.  Convert the decls (i.e. data/newtype deriving clauses,-    plus standalone deriving) to [EarlyDerivSpec]--2.  Infer the missing contexts for the InferTheta's--3.  Add the derived bindings, generating InstInfos--}--data EarlyDerivSpec = InferTheta (DerivSpec [ThetaOrigin])-                    | GivenTheta (DerivSpec ThetaType)-        -- InferTheta ds => the context for the instance should be inferred-        --      In this case ds_theta is the list of all the sets of-        --      constraints needed, such as (Eq [a], Eq a), together with a-        --      suitable CtLoc to get good error messages.-        --      The inference process is to reduce this to a-        --      simpler form (e.g. Eq a)-        ---        -- GivenTheta ds => the exact context for the instance is supplied-        --                  by the programmer; it is ds_theta-        -- See Note [Inferring the instance context] in TcDerivInfer--earlyDSLoc :: EarlyDerivSpec -> SrcSpan-earlyDSLoc (InferTheta spec) = ds_loc spec-earlyDSLoc (GivenTheta spec) = ds_loc spec--splitEarlyDerivSpec :: [EarlyDerivSpec]-                    -> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])-splitEarlyDerivSpec [] = ([],[])-splitEarlyDerivSpec (InferTheta spec : specs) =-    case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs)-splitEarlyDerivSpec (GivenTheta spec : specs) =-    case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs)--instance Outputable EarlyDerivSpec where-  ppr (InferTheta spec) = ppr spec <+> text "(Infer)"-  ppr (GivenTheta spec) = ppr spec <+> text "(Given)"--{--Note [Data decl contexts]-~~~~~~~~~~~~~~~~~~~~~~~~~-Consider--        data (RealFloat a) => Complex a = !a :+ !a deriving( Read )--We will need an instance decl like:--        instance (Read a, RealFloat a) => Read (Complex a) where-          ...--The RealFloat in the context is because the read method for Complex is bound-to construct a Complex, and doing that requires that the argument type is-in RealFloat.--But this ain't true for Show, Eq, Ord, etc, since they don't construct-a Complex; they only take them apart.--Our approach: identify the offending classes, and add the data type-context to the instance decl.  The "offending classes" are--        Read, Enum?--FURTHER NOTE ADDED March 2002.  In fact, Haskell98 now requires that-pattern matching against a constructor from a data type with a context-gives rise to the constraints for that context -- or at least the thinned-version.  So now all classes are "offending".--Note [Newtype deriving]-~~~~~~~~~~~~~~~~~~~~~~~-Consider this:-    class C a b-    instance C [a] Char-    newtype T = T Char deriving( C [a] )--Notice the free 'a' in the deriving.  We have to fill this out to-    newtype T = T Char deriving( forall a. C [a] )--And then translate it to:-    instance C [a] Char => C [a] T where ...---Note [Newtype deriving superclasses]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-(See also Trac #1220 for an interesting exchange on newtype-deriving and superclasses.)--The 'tys' here come from the partial application in the deriving-clause. The last arg is the new instance type.--We must pass the superclasses; the newtype might be an instance-of them in a different way than the representation type-E.g.            newtype Foo a = Foo a deriving( Show, Num, Eq )-Then the Show instance is not done via Coercible; it shows-        Foo 3 as "Foo 3"-The Num instance is derived via Coercible, but the Show superclass-dictionary must the Show instance for Foo, *not* the Show dictionary-gotten from the Num dictionary. So we must build a whole new dictionary-not just use the Num one.  The instance we want is something like:-     instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where-        (+) = ((+)@a)-        ...etc...-There may be a coercion needed which we get from the tycon for the newtype-when the dict is constructed in TcInstDcls.tcInstDecl2---Note [Unused constructors and deriving clauses]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See Trac #3221.  Consider-   data T = T1 | T2 deriving( Show )-Are T1 and T2 unused?  Well, no: the deriving clause expands to mention-both of them.  So we gather defs/uses from deriving just like anything else.---}---- | Stuff needed to process a datatype's `deriving` clauses-data DerivInfo = DerivInfo { di_rep_tc  :: TyCon-                             -- ^ The data tycon for normal datatypes,-                             -- or the *representation* tycon for data families-                           , di_clauses :: [LHsDerivingClause GhcRn]-                           , di_ctxt    :: SDoc -- ^ error context-                           }---- | Extract `deriving` clauses of proper data type (skips data families)-mkDerivInfos :: [LTyClDecl GhcRn] -> TcM [DerivInfo]-mkDerivInfos decls = concatMapM (mk_deriv . unLoc) decls-  where--    mk_deriv decl@(DataDecl { tcdLName = L _ data_name-                            , tcdDataDefn =-                                HsDataDefn { dd_derivs = L _ clauses } })-      = do { tycon <- tcLookupTyCon data_name-           ; return [DerivInfo { di_rep_tc = tycon, di_clauses = clauses-                               , di_ctxt = tcMkDeclCtxt decl }] }-    mk_deriv _ = return []--{---************************************************************************-*                                                                      *-\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}-*                                                                      *-************************************************************************--}--tcDeriving  :: [DerivInfo]       -- All `deriving` clauses-            -> [LDerivDecl GhcRn] -- All stand-alone deriving declarations-            -> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)-tcDeriving deriv_infos deriv_decls-  = recoverM (do { g <- getGblEnv-                 ; return (g, emptyBag, emptyValBindsOut)}) $-    do  {       -- Fish the "deriving"-related information out of the TcEnv-                -- And make the necessary "equations".-          is_boot <- tcIsHsBootOrSig-        ; traceTc "tcDeriving" (ppr is_boot)--        ; early_specs <- makeDerivSpecs is_boot deriv_infos deriv_decls-        ; traceTc "tcDeriving 1" (ppr early_specs)--        ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs-        ; insts1 <- mapM genInst given_specs-        ; insts2 <- mapM genInst infer_specs--        ; dflags <- getDynFlags--        ; let (_, deriv_stuff, fvs) = unzip3 (insts1 ++ insts2)-        ; loc <- getSrcSpanM-        ; let (binds, famInsts) = genAuxBinds dflags loc-                                    (unionManyBags deriv_stuff)--        ; let mk_inst_infos1 = map fstOf3 insts1-        ; inst_infos1 <- apply_inst_infos mk_inst_infos1 given_specs--          -- We must put all the derived type family instances (from both-          -- infer_specs and given_specs) in the local instance environment-          -- before proceeding, or else simplifyInstanceContexts might-          -- get stuck if it has to reason about any of those family instances.-          -- See Note [Staging of tcDeriving]-        ; tcExtendLocalFamInstEnv (bagToList famInsts) $-          -- NB: only call tcExtendLocalFamInstEnv once, as it performs-          -- validity checking for all of the family instances you give it.-          -- If the family instances have errors, calling it twice will result-          -- in duplicate error messages!--     do {-        -- the stand-alone derived instances (@inst_infos1@) are used when-        -- inferring the contexts for "deriving" clauses' instances-        -- (@infer_specs@)-        ; final_specs <- extendLocalInstEnv (map iSpec inst_infos1) $-                         simplifyInstanceContexts infer_specs--        ; let mk_inst_infos2 = map fstOf3 insts2-        ; inst_infos2 <- apply_inst_infos mk_inst_infos2 final_specs-        ; let inst_infos = inst_infos1 ++ inst_infos2--        ; (inst_info, rn_binds, rn_dus) <--            renameDeriv is_boot inst_infos binds--        ; unless (isEmptyBag inst_info) $-             liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"-                        (ddump_deriving inst_info rn_binds famInsts))--        ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info))-                                          getGblEnv-        ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ concat fvs)-        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } }-  where-    ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn-                   -> Bag FamInst             -- ^ Rep type family instances-                   -> SDoc-    ddump_deriving inst_infos extra_binds repFamInsts-      =    hang (text "Derived class instances:")-              2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))-                 $$ ppr extra_binds)-        $$ hangP "Derived type family instances:"-             (vcat (map pprRepTy (bagToList repFamInsts)))--    hangP s x = text "" $$ hang (ptext (sLit s)) 2 x--    -- Apply the suspended computations given by genInst calls.-    -- See Note [Staging of tcDeriving]-    apply_inst_infos :: [ThetaType -> TcM (InstInfo GhcPs)]-                     -> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs]-    apply_inst_infos = zipWithM (\f ds -> f (ds_theta ds))---- Prints the representable type family instance-pprRepTy :: FamInst -> SDoc-pprRepTy fi@(FamInst { fi_tys = lhs })-  = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+>-      equals <+> ppr rhs-  where rhs = famInstRHS fi--renameDeriv :: Bool-            -> [InstInfo GhcPs]-            -> Bag (LHsBind GhcPs, LSig GhcPs)-            -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)-renameDeriv is_boot inst_infos bagBinds-  | is_boot     -- If we are compiling a hs-boot file, don't generate any derived bindings-                -- The inst-info bindings will all be empty, but it's easier to-                -- just use rn_inst_info to change the type appropriately-  = do  { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos-        ; return ( listToBag rn_inst_infos-                 , emptyValBindsOut, usesOnly (plusFVs fvs)) }--  | otherwise-  = discardWarnings $-    -- Discard warnings about unused bindings etc-    setXOptM LangExt.EmptyCase $-    -- Derived decls (for empty types) can have-    --    case x of {}-    setXOptM LangExt.ScopedTypeVariables $-    setXOptM LangExt.KindSignatures $-    -- Derived decls (for newtype-deriving) can use ScopedTypeVariables &-    -- KindSignatures-    setXOptM LangExt.TypeApplications $-    -- GND/DerivingVia uses TypeApplications in generated code-    -- (See Note [Newtype-deriving instances] in TcGenDeriv)-    unsetXOptM LangExt.RebindableSyntax $-    -- See Note [Avoid RebindableSyntax when deriving]-    do  {-        -- Bring the extra deriving stuff into scope-        -- before renaming the instances themselves-        ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))-        ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds-        ; let aux_val_binds = ValBinds noExt aux_binds (bagToList aux_sigs)-        ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds-        ; let bndrs = collectHsValBinders rn_aux_lhs-        ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ;-        ; setEnvs envs $-    do  { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs-        ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos-        ; return (listToBag rn_inst_infos, rn_aux,-                  dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }--  where-    rn_inst_info :: InstInfo GhcPs -> TcM (InstInfo GhcRn, FreeVars)-    rn_inst_info-      inst_info@(InstInfo { iSpec = inst-                          , iBinds = InstBindings-                            { ib_binds = binds-                            , ib_tyvars = tyvars-                            , ib_pragmas = sigs-                            , ib_extensions = exts -- Only for type-checking-                            , ib_derived = sa } })-        =  ASSERT( null sigs )-           bindLocalNamesFV tyvars $-           do { (rn_binds,_, fvs) <- rnMethodBinds False (is_cls_nm inst) [] binds []-              ; let binds' = InstBindings { ib_binds = rn_binds-                                          , ib_tyvars = tyvars-                                          , ib_pragmas = []-                                          , ib_extensions = exts-                                          , ib_derived = sa }-              ; return (inst_info { iBinds = binds' }, fvs) }--{--Note [Newtype deriving and unused constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (see Trac #1954):--  module Bug(P) where-  newtype P a = MkP (IO a) deriving Monad--If you compile with -Wunused-binds you do not expect the warning-"Defined but not used: data constructor MkP". Yet the newtype deriving-code does not explicitly mention MkP, but it should behave as if you-had written-  instance Monad P where-     return x = MkP (return x)-     ...etc...--So we want to signal a user of the data constructor 'MkP'.-This is the reason behind the [Name] part of the return type-of genInst.--Note [Staging of tcDeriving]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Here's a tricky corner case for deriving (adapted from Trac #2721):--    class C a where-      type T a-      foo :: a -> T a--    instance C Int where-      type T Int = Int-      foo = id--    newtype N = N Int deriving C--This will produce an instance something like this:--    instance C N where-      type T N = T Int-      foo = coerce (foo :: Int -> T Int) :: N -> T N--We must be careful in order to typecheck this code. When determining the-context for the instance (in simplifyInstanceContexts), we need to determine-that T N and T Int have the same representation, but to do that, the T N-instance must be in the local family instance environment. Otherwise, GHC-would be unable to conclude that T Int is representationally equivalent to-T Int, and simplifyInstanceContexts would get stuck.--Previously, tcDeriving would defer adding any derived type family instances to-the instance environment until the very end, which meant that-simplifyInstanceContexts would get called without all the type family instances-it needed in the environment in order to properly simplify instance like-the C N instance above.--To avoid this scenario, we carefully structure the order of events in-tcDeriving. We first call genInst on the standalone derived instance specs and-the instance specs obtained from deriving clauses. Note that the return type of-genInst is a triple:--    TcM (ThetaType -> TcM (InstInfo RdrName), BagDerivStuff, Maybe Name)--The type family instances are in the BagDerivStuff. The first field of the-triple is a suspended computation which, given an instance context, produces-the rest of the instance. The fact that it is suspended is important, because-right now, we don't have ThetaTypes for the instances that use deriving clauses-(only the standalone-derived ones).--Now we can can collect the type family instances and extend the local instance-environment. At this point, it is safe to run simplifyInstanceContexts on the-deriving-clause instance specs, which gives us the ThetaTypes for the-deriving-clause instances. Now we can feed all the ThetaTypes to the-suspended computations and obtain our InstInfos, at which point-tcDeriving is done.--An alternative design would be to split up genInst so that the-family instances are generated separately from the InstInfos. But this would-require carving up a lot of the GHC deriving internals to accommodate the-change. On the other hand, we can keep all of the InstInfo and type family-instance logic together in genInst simply by converting genInst to-continuation-returning style, so we opt for that route.--Note [Why we don't pass rep_tc into deriveTyData]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Down in the bowels of mkEqnHelp, we need to convert the fam_tc back into-the rep_tc by means of a lookup. And yet we have the rep_tc right here!-Why look it up again? Answer: it's just easier this way.-We drop some number of arguments from the end of the datatype definition-in deriveTyData. The arguments are dropped from the fam_tc.-This action may drop a *different* number of arguments-passed to the rep_tc, depending on how many free variables, etc., the-dropped patterns have.--Also, this technique carries over the kind substitution from deriveTyData-nicely.--Note [Avoid RebindableSyntax when deriving]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The RebindableSyntax extension interacts awkwardly with the derivation of-any stock class whose methods require the use of string literals. The Show-class is a simple example (see Trac #12688):--  {-# LANGUAGE RebindableSyntax, OverloadedStrings #-}-  newtype Text = Text String-  fromString :: String -> Text-  fromString = Text--  data Foo = Foo deriving Show--This will generate code to the effect of:--  instance Show Foo where-    showsPrec _ Foo = showString "Foo"--But because RebindableSyntax and OverloadedStrings are enabled, the "Foo"-string literal is now of type Text, not String, which showString doesn't-accept! This causes the generated Show instance to fail to typecheck.--To avoid this kind of scenario, we simply turn off RebindableSyntax entirely-in derived code.--************************************************************************-*                                                                      *-                From HsSyn to DerivSpec-*                                                                      *-************************************************************************--@makeDerivSpecs@ fishes around to find the info about needed derived instances.--}--makeDerivSpecs :: Bool-               -> [DerivInfo]-               -> [LDerivDecl GhcRn]-               -> TcM [EarlyDerivSpec]-makeDerivSpecs is_boot deriv_infos deriv_decls-  = do  { -- We carefully set up uses of recoverM to minimize error message-          -- cascades. See Note [Flattening deriving clauses].-        ; eqns1 <- sequenceA-                     [ recoverM (pure Nothing)-                                (deriveClause rep_tc (fmap unLoc dcs)-                                                      pred err_ctxt)-                     | DerivInfo { di_rep_tc = rep_tc, di_clauses = clauses-                                 , di_ctxt = err_ctxt } <- deriv_infos-                     , L _ (HsDerivingClause { deriv_clause_strategy = dcs-                                             , deriv_clause_tys = L _ preds })-                         <- clauses-                     , pred <- preds-                     ]-        ; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls-        ; let eqns = catMaybes (eqns1 ++ eqns2)--        ; if is_boot then   -- No 'deriving' at all in hs-boot files-              do { unless (null eqns) (add_deriv_err (head eqns))-                 ; return [] }-          else return eqns }-  where-    add_deriv_err eqn-       = setSrcSpan (earlyDSLoc eqn) $-         addErr (hang (text "Deriving not permitted in hs-boot file")-                    2 (text "Use an instance declaration instead"))--{--Note [Flattening deriving clauses]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider what happens if you run this program (from Trac #10684) without-DeriveGeneric enabled:--    data A = A deriving (Show, Generic)-    data B = B A deriving (Show)--Naturally, you'd expect GHC to give an error to the effect of:--    Can't make a derived instance of `Generic A':-      You need -XDeriveGeneric to derive an instance for this class--And *only* that error, since the other two derived Show instances appear to be-independent of this derived Generic instance. Yet GHC also used to give this-additional error on the program above:--    No instance for (Show A)-      arising from the 'deriving' clause of a data type declaration-    When deriving the instance for (Show B)--This was happening because when GHC encountered any error within a single-data type's set of deriving clauses, it would call recoverM and move on-to the next data type's deriving clauses. One unfortunate consequence of-this design is that if A's derived Generic instance failed, so its derived-Show instance would be skipped entirely, leading to the "No instance for-(Show A)" error cascade.--The solution to this problem is to "flatten" the set of classes that are-derived for a particular data type via deriving clauses. That is, if-you have:--    newtype C = C D-      deriving (E, F, G)-      deriving anyclass (H, I, J)-      deriving newtype  (K, L, M)--Then instead of processing instances E through M under the scope of a single-recoverM, we flatten these deriving clauses into the list:--    [ E (Nothing)-    , F (Nothing)-    , G (Nothing)-    , H (Just anyclass)-    , I (Just anyclass)-    , J (Just anyclass)-    , K (Just newtype)-    , L (Just newtype)-    , M (Just newtype) ]--And then process each class individually, under its own recoverM scope. That-way, failure to derive one class doesn't cancel out other classes in the-same set of clause-derived classes.--}----------------------------------------------------------------------- | Process a single class in a `deriving` clause.-deriveClause :: TyCon -> Maybe (DerivStrategy GhcRn)-             -> LHsSigType GhcRn -> SDoc-             -> TcM (Maybe EarlyDerivSpec)-deriveClause rep_tc mb_strat pred err_ctxt-  = addErrCtxt err_ctxt $-    deriveTyData tvs tc tys mb_strat pred-  where-    tvs = tyConTyVars rep_tc-    (tc, tys) = case tyConFamInstSig_maybe rep_tc of-                        -- data family:-                  Just (fam_tc, pats, _) -> (fam_tc, pats)-      -- NB: deriveTyData wants the *user-specified*-      -- name. See Note [Why we don't pass rep_tc into deriveTyData]--                  _ -> (rep_tc, mkTyVarTys tvs)     -- datatype---------------------------------------------------------------------deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec)--- Process a single standalone deriving declaration---  e.g.   deriving instance Show a => Show (T a)--- Rather like tcLocalInstDecl------ This returns a Maybe because the user might try to derive Typeable, which is--- a no-op nowadays.-deriveStandalone (L loc (DerivDecl _ deriv_ty mbl_deriv_strat overlap_mode))-  = setSrcSpan loc                   $-    addErrCtxt (standaloneCtxt deriv_ty)  $-    do { traceTc "Standalone deriving decl for" (ppr deriv_ty)-       ; let mb_deriv_strat = fmap unLoc mbl_deriv_strat-             ctxt           = TcType.InstDeclCtxt True-       ; traceTc "Deriving strategy (standalone deriving)" $-           vcat [ppr mb_deriv_strat, ppr deriv_ty]-       ; (mb_deriv_strat', tvs', (deriv_ctxt', cls, inst_tys'))-           <- tcDerivStrategy mb_deriv_strat $ do-                (tvs, deriv_ctxt, cls, inst_tys)-                  <- tcStandaloneDerivInstType ctxt deriv_ty-                pure (tvs, (deriv_ctxt, cls, inst_tys))-       ; checkTc (not (null inst_tys')) derivingNullaryErr-       ; let inst_ty' = last inst_tys'-         -- See Note [Unify kinds in deriving]-       ; (tvs, deriv_ctxt, inst_tys) <--           case mb_deriv_strat' of-             -- Perform an additional unification with the kind of the `via`-             -- type and the result of the previous kind unification.-             Just (ViaStrategy via_ty) -> do-               let via_kind     = tcTypeKind via_ty-                   inst_ty_kind = tcTypeKind inst_ty'-                   mb_match     = tcUnifyTy inst_ty_kind via_kind--               checkTc (isJust mb_match)-                       (derivingViaKindErr cls inst_ty_kind-                                           via_ty via_kind)--               let Just kind_subst = mb_match-                   ki_subst_range  = getTCvSubstRangeFVs kind_subst-                   -- See Note [Unification of two kind variables in deriving]-                   unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst-                                        && not (v `elemVarSet` ki_subst_range))-                                          tvs'-                   (subst, _)    = substTyVarBndrs kind_subst unmapped_tkvs-                   (final_deriv_ctxt, final_deriv_ctxt_tys)-                     = case deriv_ctxt' of-                         InferContext wc -> (InferContext wc, [])-                         SupplyContext theta ->-                           let final_theta = substTheta subst theta-                           in (SupplyContext final_theta, final_theta)-                   final_inst_tys   = substTys subst inst_tys'-                   final_tvs        = tyCoVarsOfTypesWellScoped $-                                      final_deriv_ctxt_tys ++ final_inst_tys-               pure (final_tvs, final_deriv_ctxt, final_inst_tys)--             _ -> pure (tvs', deriv_ctxt', inst_tys')-       ; let cls_tys = take (length inst_tys - 1) inst_tys-             inst_ty = last inst_tys-       ; traceTc "Standalone deriving;" $ vcat-              [ text "tvs:" <+> ppr tvs-              , text "mb_deriv_strat:" <+> ppr mb_deriv_strat'-              , text "deriv_ctxt:" <+> ppr deriv_ctxt-              , text "cls:" <+> ppr cls-              , text "tys:" <+> ppr inst_tys ]-                -- C.f. TcInstDcls.tcLocalInstDecl1-       ; traceTc "Standalone deriving:" $ vcat-              [ text "class:" <+> ppr cls-              , text "class types:" <+> ppr cls_tys-              , text "type:" <+> ppr inst_ty ]--       ; let bale_out msg = failWithTc (derivingThingErr False cls cls_tys-                              inst_ty mb_deriv_strat' msg)--       ; case tcSplitTyConApp_maybe inst_ty of-           Just (tc, tc_args)-              | className cls == typeableClassName-              -> do warnUselessTypeable-                    return Nothing--              | otherwise-              -> Just <$> mkEqnHelp (fmap unLoc overlap_mode)-                                    tvs cls cls_tys tc tc_args-                                    deriv_ctxt mb_deriv_strat'--           _  -> -- Complain about functions, primitive types, etc,-                 bale_out $-                 text "The last argument of the instance must be a data or newtype application"-        }-deriveStandalone (L _ (XDerivDecl _)) = panic "deriveStandalone"---- Typecheck the type in a standalone deriving declaration.------ This may appear dense, but it's mostly huffing and puffing to recognize--- the special case of a type with an extra-constraints wildcard context, e.g.,------   deriving instance _ => Eq (Foo a)------ If there is such a wildcard, we typecheck this as if we had written--- @deriving instance Eq (Foo a)@, and return @'InferContext' ('Just' loc)@,--- as the 'DerivContext', where loc is the location of the wildcard used for--- error reporting. This indicates that we should infer the context as if we--- were deriving Eq via a deriving clause--- (see Note [Inferring the instance context] in TcDerivInfer).------ If there is no wildcard, then proceed as normal, and instead return--- @'SupplyContext' theta@, where theta is the typechecked context.------ Note that this will never return @'InferContext' 'Nothing'@, as that can--- only happen with @deriving@ clauses.-tcStandaloneDerivInstType-  :: UserTypeCtxt -> LHsSigWcType GhcRn-  -> TcM ([TyVar], DerivContext, Class, [Type])-tcStandaloneDerivInstType ctxt-    (HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = vars-                                       , hsib_body   = deriv_ty_body })})-  | (tvs, theta, rho) <- splitLHsSigmaTy deriv_ty_body-  , L _ [wc_pred] <- theta-  , L wc_span (HsWildCardTy _) <- ignoreParens wc_pred-  = do dfun_ty <- tcHsClsInstType ctxt $-                  HsIB { hsib_ext = vars-                       , hsib_body-                           = L (getLoc deriv_ty_body) $-                             HsForAllTy { hst_bndrs = tvs-                                        , hst_xforall = noExt-                                        , hst_body  = rho }}-       let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty-       pure (tvs, InferContext (Just wc_span), cls, inst_tys)-  | otherwise-  = do dfun_ty <- tcHsClsInstType ctxt deriv_ty-       let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty-       pure (tvs, SupplyContext theta, cls, inst_tys)--tcStandaloneDerivInstType _ (HsWC _ (XHsImplicitBndrs _))-  = panic "tcStandaloneDerivInstType"-tcStandaloneDerivInstType _ (XHsWildCardBndrs _)-  = panic "tcStandaloneDerivInstType"--warnUselessTypeable :: TcM ()-warnUselessTypeable-  = do { warn <- woptM Opt_WarnDerivingTypeable-       ; when warn $ addWarnTc (Reason Opt_WarnDerivingTypeable)-                   $ text "Deriving" <+> quotes (ppr typeableClassName) <+>-                     text "has no effect: all types now auto-derive Typeable" }---------------------------------------------------------------------deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance-                    -- Can be a data instance, hence [Type] args-                    -- and in that case the TyCon is the /family/ tycon-             -> Maybe (DerivStrategy GhcRn)  -- The optional deriving strategy-             -> LHsSigType GhcRn             -- The deriving predicate-             -> TcM (Maybe EarlyDerivSpec)--- The deriving clause of a data or newtype declaration--- I.e. not standalone deriving------ This returns a Maybe because the user might try to derive Typeable, which is--- a no-op nowadays.-deriveTyData tvs tc tc_args mb_deriv_strat deriv_pred-  = setSrcSpan (getLoc (hsSigType deriv_pred)) $-    -- Use loc of the 'deriving' item-    do  { (mb_deriv_strat', deriv_tvs, (cls, cls_tys, cls_arg_kinds))-                <- tcExtendTyVarEnv tvs $-                -- Deriving preds may (now) mention-                -- the type variables for the type constructor, hence tcExtendTyVarenv-                -- The "deriv_pred" is a LHsType to take account of the fact that for-                -- newtype deriving we allow deriving (forall a. C [a]).--                -- Typeable is special, because Typeable :: forall k. k -> Constraint-                -- so the argument kind 'k' is not decomposable by splitKindFunTys-                -- as is the case for all other derivable type classes-                     tcDerivStrategy mb_deriv_strat $-                     tcHsDeriv deriv_pred--        ; when (cls_arg_kinds `lengthIsNot` 1) $-            failWithTc (nonUnaryErr deriv_pred)-        ; let [cls_arg_kind] = cls_arg_kinds-        ; if className cls == typeableClassName-          then do warnUselessTypeable-                  return Nothing-          else--     do {  -- Given data T a b c = ... deriving( C d ),-           -- we want to drop type variables from T so that (C d (T a)) is well-kinded-          let (arg_kinds, _)  = splitFunTys cls_arg_kind-              n_args_to_drop  = length arg_kinds-              n_args_to_keep  = length tc_args - n_args_to_drop-                                -- See Note [tc_args and tycon arity]-              (tc_args_to_keep, args_to_drop)-                              = splitAt n_args_to_keep tc_args-              inst_ty_kind    = tcTypeKind (mkTyConApp tc tc_args_to_keep)--              -- Match up the kinds, and apply the resulting kind substitution-              -- to the types.  See Note [Unify kinds in deriving]-              -- We are assuming the tycon tyvars and the class tyvars are distinct-              mb_match        = tcUnifyTy inst_ty_kind cls_arg_kind-              enough_args     = n_args_to_keep >= 0--        -- Check that the result really is well-kinded-        ; checkTc (enough_args && isJust mb_match)-                  (derivingKindErr tc cls cls_tys cls_arg_kind enough_args)--        ; let propagate_subst kind_subst tkvs' cls_tys' tc_args'-                = (final_tkvs, final_cls_tys, final_tc_args)-                where-                  ki_subst_range  = getTCvSubstRangeFVs kind_subst-                  -- See Note [Unification of two kind variables in deriving]-                  unmapped_tkvs   = filter (\v -> v `notElemTCvSubst` kind_subst-                                         && not (v `elemVarSet` ki_subst_range))-                                           tkvs'-                  (subst, _)      = substTyVarBndrs kind_subst unmapped_tkvs-                  final_tc_args   = substTys subst tc_args'-                  final_cls_tys   = substTys subst cls_tys'-                  final_tkvs      = tyCoVarsOfTypesWellScoped $-                                    final_cls_tys ++ final_tc_args--        ; let tkvs = scopedSort $ fvVarList $-                     unionFV (tyCoFVsOfTypes tc_args_to_keep)-                             (FV.mkFVs deriv_tvs)-              Just kind_subst = mb_match-              (tkvs', final_cls_tys', final_tc_args')-                = propagate_subst kind_subst tkvs cls_tys tc_args_to_keep--          -- See Note [Unify kinds in deriving]-        ; (tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) <--            case mb_deriv_strat' of-              -- Perform an additional unification with the kind of the `via`-              -- type and the result of the previous kind unification.-              Just (ViaStrategy via_ty) -> do-                let final_via_ty   = via_ty-                    final_via_kind = tcTypeKind final_via_ty-                    final_inst_ty_kind-                              = tcTypeKind (mkTyConApp tc final_tc_args')-                    via_match = tcUnifyTy final_inst_ty_kind final_via_kind--                checkTc (isJust via_match)-                        (derivingViaKindErr cls final_inst_ty_kind-                                            final_via_ty final_via_kind)--                let Just via_subst = via_match-                    (final_tkvs, final_cls_tys, final_tc_args)-                      = propagate_subst via_subst tkvs'-                                        final_cls_tys' final_tc_args'-                pure ( final_tkvs, final_cls_tys, final_tc_args-                     , Just $ ViaStrategy $ substTy via_subst via_ty-                     )--              _ -> pure ( tkvs', final_cls_tys', final_tc_args'-                        , mb_deriv_strat' )--        ; traceTc "Deriving strategy (deriving clause)" $-            vcat [ppr final_mb_deriv_strat, ppr deriv_pred]--        ; traceTc "derivTyData1" (vcat [ pprTyVars tvs, ppr tc, ppr tc_args-                                       , ppr deriv_pred-                                       , pprTyVars (tyCoVarsOfTypesList tc_args)-                                       , ppr n_args_to_keep, ppr n_args_to_drop-                                       , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match-                                       , ppr final_tc_args, ppr final_cls_tys ])--        ; traceTc "derivTyData2" (vcat [ ppr tkvs ])--        ; let final_tc_app = mkTyConApp tc final_tc_args-        ; checkTc (allDistinctTyVars (mkVarSet tkvs) args_to_drop)     -- (a, b, c)-                  (derivingEtaErr cls final_cls_tys final_tc_app)-                -- Check that-                --  (a) The args to drop are all type variables; eg reject:-                --              data instance T a Int = .... deriving( Monad )-                --  (b) The args to drop are all *distinct* type variables; eg reject:-                --              class C (a :: * -> * -> *) where ...-                --              data instance T a a = ... deriving( C )-                --  (c) The type class args, or remaining tycon args,-                --      do not mention any of the dropped type variables-                --              newtype T a s = ... deriving( ST s )-                --              newtype instance K a a = ... deriving( Monad )-                ---                -- It is vital that the implementation of allDistinctTyVars-                -- expand any type synonyms.-                -- See Note [Eta-reducing type synonyms]--        ; checkValidInstHead DerivClauseCtxt cls $-                             final_cls_tys ++ [final_tc_app]-                -- Check that we aren't deriving an instance of a magical-                -- type like (~) or Coercible (#14916).--        ; spec <- mkEqnHelp Nothing tkvs-                            cls final_cls_tys tc final_tc_args-                            (InferContext Nothing) final_mb_deriv_strat-        ; traceTc "derivTyData" (ppr spec)-        ; return $ Just spec } }---{- Note [tc_args and tycon arity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-You might wonder if we could use (tyConArity tc) at this point, rather-than (length tc_args).  But for data families the two can differ!  The-tc and tc_args passed into 'deriveTyData' come from 'deriveClause' which-in turn gets them from 'tyConFamInstSig_maybe' which in turn gets them-from DataFamInstTyCon:--| DataFamInstTyCon          -- See Note [Data type families]-      (CoAxiom Unbranched)-      TyCon   -- The family TyCon-      [Type]  -- Argument types (mentions the tyConTyVars of this TyCon)-              -- No shorter in length than the tyConTyVars of the family TyCon-              -- How could it be longer? See [Arity of data families] in FamInstEnv--Notice that the arg tys might not be the same as the family tycon arity-(= length tyConTyVars).--Note [Unify kinds in deriving]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (Trac #8534)-    data T a b = MkT a deriving( Functor )-    -- where Functor :: (*->*) -> Constraint--So T :: forall k. * -> k -> *.   We want to get-    instance Functor (T * (a:*)) where ...-Notice the '*' argument to T.--Moreover, as well as instantiating T's kind arguments, we may need to instantiate-C's kind args.  Consider (Trac #8865):-  newtype T a b = MkT (Either a b) deriving( Category )-where-  Category :: forall k. (k -> k -> *) -> Constraint-We need to generate the instance-  instance Category * (Either a) where ...-Notice the '*' argument to Category.--So we need to- * drop arguments from (T a b) to match the number of-   arrows in the (last argument of the) class;- * and then *unify* kind of the remaining type against the-   expected kind, to figure out how to instantiate C's and T's-   kind arguments.--In the two examples,- * we unify   kind-of( T k (a:k) ) ~ kind-of( Functor )-         i.e.      (k -> *) ~ (* -> *)   to find k:=*.-         yielding  k:=*-- * we unify   kind-of( Either ) ~ kind-of( Category )-         i.e.      (* -> * -> *)  ~ (k -> k -> k)-         yielding  k:=*--Now we get a kind substitution.  We then need to:--  1. Remove the substituted-out kind variables from the quantified kind vars--  2. Apply the substitution to the kinds of quantified *type* vars-     (and extend the substitution to reflect this change)--  3. Apply that extended substitution to the non-dropped args (types and-     kinds) of the type and class--Forgetting step (2) caused Trac #8893:-  data V a = V [a] deriving Functor-  data P (x::k->*) (a:k) = P (x a) deriving Functor-  data C (x::k->*) (a:k) = C (V (P x a)) deriving Functor--When deriving Functor for P, we unify k to *, but we then want-an instance   $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*))-and similarly for C.  Notice the modified kind of x, both at binding-and occurrence sites.--This can lead to some surprising results when *visible* kind binder is-unified (in contrast to the above examples, in which only non-visible kind-binders were considered). Consider this example from Trac #11732:--    data T k (a :: k) = MkT deriving Functor--Since unification yields k:=*, this results in a generated instance of:--    instance Functor (T *) where ...--which looks odd at first glance, since one might expect the instance head-to be of the form Functor (T k). Indeed, one could envision an alternative-generated instance of:--    instance (k ~ *) => Functor (T k) where--But this does not typecheck by design: kind equalities are not allowed to be-bound in types, only terms. But in essence, the two instance declarations are-entirely equivalent, since even though (T k) matches any kind k, the only-possibly value for k is *, since anything else is ill-typed. As a result, we can-just as comfortably use (T *).--Another way of thinking about is: deriving clauses often infer constraints.-For example:--    data S a = S a deriving Eq--infers an (Eq a) constraint in the derived instance. By analogy, when we-are deriving Functor, we might infer an equality constraint (e.g., k ~ *).-The only distinction is that GHC instantiates equality constraints directly-during the deriving process.--Another quirk of this design choice manifests when typeclasses have visible-kind parameters. Consider this code (also from Trac #11732):--    class Cat k (cat :: k -> k -> *) where-      catId   :: cat a a-      catComp :: cat b c -> cat a b -> cat a c--    instance Cat * (->) where-      catId   = id-      catComp = (.)--    newtype Fun a b = Fun (a -> b) deriving (Cat k)--Even though we requested a derived instance of the form (Cat k Fun), the-kind unification will actually generate (Cat * Fun) (i.e., the same thing as if-the user wrote deriving (Cat *)).--What happens with DerivingVia, when you have yet another type? Consider:--  newtype Foo (a :: Type) = MkFoo (Proxy a)-    deriving Functor via Proxy--As before, we unify the kind of Foo (* -> *) with the kind of the argument to-Functor (* -> *). But that's not enough: the `via` type, Proxy, has the kind-(k -> *), which is more general than what we want. So we must additionally-unify (k -> *) with (* -> *).--Currently, all of this unification is implemented kludgily with the pure-unifier, which is rather tiresome. Trac #14331 lays out a plan for how this-might be made cleaner.--Note [Unification of two kind variables in deriving]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As a special case of the Note above, it is possible to derive an instance of-a poly-kinded typeclass for a poly-kinded datatype. For example:--    class Category (cat :: k -> k -> *) where-    newtype T (c :: k -> k -> *) a b = MkT (c a b) deriving Category--This case is suprisingly tricky. To see why, let's write out what instance GHC-will attempt to derive (using -fprint-explicit-kinds syntax):--    instance Category k1 (T k2 c) where ...--GHC will attempt to unify k1 and k2, which produces a substitution (kind_subst)-that looks like [k2 :-> k1]. Importantly, we need to apply this substitution to-the type variable binder for c, since its kind is (k2 -> k2 -> *).--We used to accomplish this by doing the following:--    unmapped_tkvs = filter (`notElemTCvSubst` kind_subst) all_tkvs-    (subst, _)    = substTyVarBndrs kind_subst unmapped_tkvs--Where all_tkvs contains all kind variables in the class and instance types (in-this case, all_tkvs = [k1,k2]). But since kind_subst only has one mapping,-this results in unmapped_tkvs being [k1], and as a consequence, k1 gets mapped-to another kind variable in subst! That is, subst = [k2 :-> k1, k1 :-> k_new].-This is bad, because applying that substitution yields the following instance:--   instance Category k_new (T k1 c) where ...--In other words, keeping k1 in unmapped_tvks taints the substitution, resulting-in an ill-kinded instance (this caused Trac #11837).--To prevent this, we need to filter out any variable from all_tkvs which either--1. Appears in the domain of kind_subst. notElemTCvSubst checks this.-2. Appears in the range of kind_subst. To do this, we compute the free-   variable set of the range of kind_subst with getTCvSubstRangeFVs, and check-   if a kind variable appears in that set.--Note [Eta-reducing type synonyms]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-One can instantiate a type in a data family instance with a type synonym that-mentions other type variables:--  type Const a b = a-  data family Fam (f :: * -> *) (a :: *)-  newtype instance Fam f (Const a f) = Fam (f a) deriving Functor--It is also possible to define kind synonyms, and they can mention other types in-a datatype declaration. For example,--  type Const a b = a-  newtype T f (a :: Const * f) = T (f a) deriving Functor--When deriving, we need to perform eta-reduction analysis to ensure that none of-the eta-reduced type variables are mentioned elsewhere in the declaration. But-we need to be careful, because if we don't expand through the Const type-synonym, we will mistakenly believe that f is an eta-reduced type variable and-fail to derive Functor, even though the code above is correct (see Trac #11416,-where this was first noticed). For this reason, we expand the type synonyms in-the eta-reduced types before doing any analysis.--}--mkEqnHelp :: Maybe OverlapMode-          -> [TyVar]-          -> Class -> [Type]-          -> TyCon -> [Type]-          -> DerivContext-               -- SupplyContext => context supplied (standalone deriving)-               -- InferContext  => context inferred (deriving on data decl, or-               --                  standalone deriving decl with a wildcard)-          -> Maybe (DerivStrategy GhcTc)-          -> TcRn EarlyDerivSpec--- Make the EarlyDerivSpec for an instance---      forall tvs. theta => cls (tys ++ [ty])--- where the 'theta' is optional (that's the Maybe part)--- Assumes that this declaration is well-kinded--mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args deriv_ctxt deriv_strat-  = do {      -- Find the instance of a data family-              -- Note [Looking up family instances for deriving]-         fam_envs <- tcGetFamInstEnvs-       ; let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tycon tc_args-              -- If it's still a data family, the lookup failed; i.e no instance exists-       ; when (isDataFamilyTyCon rep_tc)-              (bale_out (text "No family instance for" <+> quotes (pprTypeApp tycon tc_args)))-       ; is_boot <- tcIsHsBootOrSig-       ; when is_boot $-              bale_out (text "Cannot derive instances in hs-boot files"-                    $+$ text "Write an instance declaration instead")--       ; let deriv_env = DerivEnv-                         { denv_overlap_mode = overlap_mode-                         , denv_tvs          = tvs-                         , denv_cls          = cls-                         , denv_cls_tys      = cls_tys-                         , denv_tc           = tycon-                         , denv_tc_args      = tc_args-                         , denv_rep_tc       = rep_tc-                         , denv_rep_tc_args  = rep_tc_args-                         , denv_ctxt         = deriv_ctxt-                         , denv_strat        = deriv_strat }-       ; flip runReaderT deriv_env $-         if isNewTyCon rep_tc then mkNewTypeEqn else mkDataTypeEqn }-  where-     bale_out msg = failWithTc (derivingThingErr False cls cls_tys-                      (mkTyConApp tycon tc_args) deriv_strat msg)--{--Note [Looking up family instances for deriving]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-tcLookupFamInstExact is an auxiliary lookup wrapper which requires-that looked-up family instances exist.  If called with a vanilla-tycon, the old type application is simply returned.--If we have-  data instance F () = ... deriving Eq-  data instance F () = ... deriving Eq-then tcLookupFamInstExact will be confused by the two matches;-but that can't happen because tcInstDecls1 doesn't call tcDeriving-if there are any overlaps.--There are two other things that might go wrong with the lookup.-First, we might see a standalone deriving clause-   deriving Eq (F ())-when there is no data instance F () in scope.--Note that it's OK to have-  data instance F [a] = ...-  deriving Eq (F [(a,b)])-where the match is not exact; the same holds for ordinary data types-with standalone deriving declarations.--Note [Deriving, type families, and partial applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When there are no type families, it's quite easy:--    newtype S a = MkS [a]-    -- :CoS :: S  ~ []  -- Eta-reduced--    instance Eq [a] => Eq (S a)         -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a)-    instance Monad [] => Monad S        -- by coercion sym (Monad :CoS)  : Monad [] ~ Monad S--When type familes are involved it's trickier:--    data family T a b-    newtype instance T Int a = MkT [a] deriving( Eq, Monad )-    -- :RT is the representation type for (T Int a)-    --  :Co:RT    :: :RT ~ []          -- Eta-reduced!-    --  :CoF:RT a :: T Int a ~ :RT a   -- Also eta-reduced!--    instance Eq [a] => Eq (T Int a)     -- easy by coercion-       -- d1 :: Eq [a]-       -- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a))--    instance Monad [] => Monad (T Int)  -- only if we can eta reduce???-       -- d1 :: Monad []-       -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT))--Note the need for the eta-reduced rule axioms.  After all, we can-write it out-    instance Monad [] => Monad (T Int)  -- only if we can eta reduce???-      return x = MkT [x]-      ... etc ...--See Note [Eta reduction for data families] in FamInstEnv--%************************************************************************-%*                                                                      *-                Deriving data types-*                                                                      *-************************************************************************--}---- | Derive an instance for a data type (i.e., non-newtype).-mkDataTypeEqn :: DerivM EarlyDerivSpec-mkDataTypeEqn-  = do mb_strat <- asks denv_strat-       let bale_out msg = do err <- derivingThingErrM False msg-                             lift $ failWithTc err-       case mb_strat of-         Just StockStrategy    -> mk_eqn_stock    mk_originative_eqn bale_out-         Just AnyclassStrategy -> mk_eqn_anyclass mk_originative_eqn bale_out-         Just (ViaStrategy ty) -> mk_eqn_via ty-         -- GeneralizedNewtypeDeriving makes no sense for non-newtypes-         Just NewtypeStrategy  -> bale_out gndNonNewtypeErr-         -- Lacking a user-requested deriving strategy, we will try to pick-         -- between the stock or anyclass strategies-         Nothing -> mk_eqn_no_mechanism mk_originative_eqn bale_out---- Derive an instance by way of an originative deriving strategy--- (stock or anyclass).------ See Note [Deriving strategies]-mk_originative_eqn-  :: DerivSpecMechanism -- Invariant: This will be DerivSpecStock or-                        -- DerivSpecAnyclass-  -> DerivM EarlyDerivSpec-mk_originative_eqn mechanism-  = do DerivEnv { denv_overlap_mode = overlap_mode-                , denv_tvs          = tvs-                , denv_tc           = tc-                , denv_tc_args      = tc_args-                , denv_rep_tc       = rep_tc-                , denv_cls          = cls-                , denv_cls_tys      = cls_tys-                , denv_ctxt         = deriv_ctxt } <- ask-       let inst_ty  = mkTyConApp tc tc_args-           inst_tys = cls_tys ++ [inst_ty]-       doDerivInstErrorChecks1 mechanism-       loc       <- lift getSrcSpanM-       dfun_name <- lift $ newDFunName' cls tc-       case deriv_ctxt of-        InferContext wildcard ->-          do { (inferred_constraints, tvs', inst_tys')-                 <- inferConstraints mechanism-             ; return $ InferTheta $ DS-                   { ds_loc = loc-                   , ds_name = dfun_name, ds_tvs = tvs'-                   , ds_cls = cls, ds_tys = inst_tys'-                   , ds_tc = rep_tc-                   , ds_theta = inferred_constraints-                   , ds_overlap = overlap_mode-                   , ds_standalone_wildcard = wildcard-                   , ds_mechanism = mechanism } }--        SupplyContext theta ->-            return $ GivenTheta $ DS-                   { ds_loc = loc-                   , ds_name = dfun_name, ds_tvs = tvs-                   , ds_cls = cls, ds_tys = inst_tys-                   , ds_tc = rep_tc-                   , ds_theta = theta-                   , ds_overlap = overlap_mode-                   , ds_standalone_wildcard = Nothing-                   , ds_mechanism = mechanism }---- Derive an instance by way of a coerce-based deriving strategy--- (newtype or via).------ See Note [Deriving strategies]-mk_coerce_based_eqn-  :: (Type -> DerivSpecMechanism) -- Invariant: This will be DerivSpecNewtype-                                  -- or DerivSpecVia-  -> Type -- The type to coerce-  -> DerivM EarlyDerivSpec-mk_coerce_based_eqn mk_mechanism coerced_ty-  = do DerivEnv { denv_overlap_mode = overlap_mode-                , denv_tvs          = tvs-                , denv_tc           = tycon-                , denv_tc_args      = tc_args-                , denv_rep_tc       = rep_tycon-                , denv_cls          = cls-                , denv_cls_tys      = cls_tys-                , denv_ctxt         = deriv_ctxt } <- ask-       sa_wildcard <- isStandaloneWildcardDeriv-       let -- The following functions are polymorphic over the representation-           -- type, since we might either give it the underlying type of a-           -- newtype (for GeneralizedNewtypeDeriving) or a @via@ type-           -- (for DerivingVia).-           rep_tys ty  = cls_tys ++ [ty]-           rep_pred ty = mkClassPred cls (rep_tys ty)-           rep_pred_o ty = mkPredOrigin deriv_origin TypeLevel (rep_pred ty)-                   -- rep_pred is the representation dictionary, from where-                   -- we are going to get all the methods for the final-                   -- dictionary--           -- Next we figure out what superclass dictionaries to use-           -- See Note [Newtype deriving superclasses] above-           sc_preds   :: [PredOrigin]-           cls_tyvars = classTyVars cls-           inst_ty    = mkTyConApp tycon tc_args-           inst_tys   = cls_tys ++ [inst_ty]-           sc_preds   = map (mkPredOrigin deriv_origin TypeLevel) $-                        substTheta (zipTvSubst cls_tyvars inst_tys) $-                        classSCTheta cls-           deriv_origin = mkDerivOrigin sa_wildcard--           -- Next we collect constraints for the class methods-           -- If there are no methods, we don't need any constraints-           -- Otherwise we need (C rep_ty), for the representation methods,-           -- and constraints to coerce each individual method-           meth_preds :: Type -> [PredOrigin]-           meths = classMethods cls-           meth_preds ty-             | null meths = [] -- No methods => no constraints-                               -- (Trac #12814)-             | otherwise = rep_pred_o ty : coercible_constraints ty-           coercible_constraints ty-             = [ mkPredOrigin (DerivOriginCoerce meth t1 t2 sa_wildcard)-                              TypeLevel (mkReprPrimEqPred t1 t2)-               | meth <- meths-               , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs-                                            inst_tys ty meth ]--           all_thetas :: Type -> [ThetaOrigin]-           all_thetas ty = [mkThetaOriginFromPreds $ meth_preds ty ++ sc_preds]--           inferred_thetas = all_thetas coerced_ty-       lift $ traceTc "newtype deriving:" $-         ppr tycon <+> ppr (rep_tys coerced_ty) <+> ppr inferred_thetas-       let mechanism = mk_mechanism coerced_ty-           bale_out msg = do err <- derivingThingErrMechanism mechanism msg-                             lift $ failWithTc err-       atf_coerce_based_error_checks cls bale_out-       doDerivInstErrorChecks1 mechanism-       dfun_name <- lift $ newDFunName' cls tycon-       loc       <- lift getSrcSpanM-       case deriv_ctxt of-        SupplyContext theta -> return $ GivenTheta $ DS-            { ds_loc = loc-            , ds_name = dfun_name, ds_tvs = tvs-            , ds_cls = cls, ds_tys = inst_tys-            , ds_tc = rep_tycon-            , ds_theta = theta-            , ds_overlap = overlap_mode-            , ds_standalone_wildcard = Nothing-            , ds_mechanism = mechanism }-        InferContext wildcard -> return $ InferTheta $ DS-            { ds_loc = loc-            , ds_name = dfun_name, ds_tvs = tvs-            , ds_cls = cls, ds_tys = inst_tys-            , ds_tc = rep_tycon-            , ds_theta = inferred_thetas-            , ds_overlap = overlap_mode-            , ds_standalone_wildcard = wildcard-            , ds_mechanism = mechanism }---- Ensure that a class's associated type variables are suitable for--- GeneralizedNewtypeDeriving or DerivingVia.------ See Note [GND and associated type families]-atf_coerce_based_error_checks-  :: Class-  -> (SDoc -> DerivM ())-  -> DerivM ()-atf_coerce_based_error_checks cls bale_out-  = let cls_tyvars = classTyVars cls--        ats_look_sensible-           =  -- Check (a) from Note [GND and associated type families]-              no_adfs-              -- Check (b) from Note [GND and associated type families]-           && isNothing at_without_last_cls_tv-              -- Check (d) from Note [GND and associated type families]-           && isNothing at_last_cls_tv_in_kinds--        (adf_tcs, atf_tcs) = partition isDataFamilyTyCon at_tcs-        no_adfs            = null adf_tcs-               -- We cannot newtype-derive data family instances--        at_without_last_cls_tv-          = find (\tc -> last_cls_tv `notElem` tyConTyVars tc) atf_tcs-        at_last_cls_tv_in_kinds-          = find (\tc -> any (at_last_cls_tv_in_kind . tyVarKind)-                             (tyConTyVars tc)-                      || at_last_cls_tv_in_kind (tyConResKind tc)) atf_tcs-        at_last_cls_tv_in_kind kind-          = last_cls_tv `elemVarSet` exactTyCoVarsOfType kind-        at_tcs = classATs cls-        last_cls_tv = ASSERT( notNull cls_tyvars )-                      last cls_tyvars--        cant_derive_err-           = vcat [ ppUnless no_adfs adfs_msg-                  , maybe empty at_without_last_cls_tv_msg-                          at_without_last_cls_tv-                  , maybe empty at_last_cls_tv_in_kinds_msg-                          at_last_cls_tv_in_kinds-                  ]-        adfs_msg  = text "the class has associated data types"-        at_without_last_cls_tv_msg at_tc = hang-          (text "the associated type" <+> quotes (ppr at_tc)-           <+> text "is not parameterized over the last type variable")-          2 (text "of the class" <+> quotes (ppr cls))-        at_last_cls_tv_in_kinds_msg at_tc = hang-          (text "the associated type" <+> quotes (ppr at_tc)-           <+> text "contains the last type variable")-         2 (text "of the class" <+> quotes (ppr cls)-           <+> text "in a kind, which is not (yet) allowed")-    in unless ats_look_sensible $ bale_out cant_derive_err--mk_eqn_stock :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)-             -> (SDoc -> DerivM EarlyDerivSpec)-             -> DerivM EarlyDerivSpec-mk_eqn_stock go_for_it bale_out-  = do DerivEnv { denv_tc      = tc-                , denv_rep_tc  = rep_tc-                , denv_cls     = cls-                , denv_cls_tys = cls_tys-                , denv_ctxt    = deriv_ctxt } <- ask-       dflags <- getDynFlags-       case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys-                                           tc rep_tc of-         CanDeriveStock gen_fn -> go_for_it $ DerivSpecStock gen_fn-         StockClassError msg   -> bale_out msg-         _                     -> bale_out (nonStdErr cls)--mk_eqn_anyclass :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)-                -> (SDoc -> DerivM EarlyDerivSpec)-                -> DerivM EarlyDerivSpec-mk_eqn_anyclass go_for_it bale_out-  = do dflags <- getDynFlags-       case canDeriveAnyClass dflags of-         IsValid      -> go_for_it DerivSpecAnyClass-         NotValid msg -> bale_out msg--mk_eqn_newtype :: Type -- The newtype's representation type-               -> DerivM EarlyDerivSpec-mk_eqn_newtype = mk_coerce_based_eqn DerivSpecNewtype--mk_eqn_via :: Type -- The @via@ type-           -> DerivM EarlyDerivSpec-mk_eqn_via = mk_coerce_based_eqn DerivSpecVia--mk_eqn_no_mechanism :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)-                    -> (SDoc -> DerivM EarlyDerivSpec)-                    -> DerivM EarlyDerivSpec-mk_eqn_no_mechanism go_for_it bale_out-  = do DerivEnv { denv_tc      = tc-                , denv_rep_tc  = rep_tc-                , denv_cls     = cls-                , denv_cls_tys = cls_tys-                , denv_ctxt    = deriv_ctxt } <- ask-       dflags <- getDynFlags--           -- See Note [Deriving instances for classes themselves]-       let dac_error msg-             | isClassTyCon rep_tc-             = quotes (ppr tc) <+> text "is a type class,"-                               <+> text "and can only have a derived instance"-                               $+$ text "if DeriveAnyClass is enabled"-             | otherwise-             = nonStdErr cls $$ msg--       case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys-                                           tc rep_tc of-           -- NB: pass the *representation* tycon to-           -- checkOriginativeSideConditions-           NonDerivableClass   msg -> bale_out (dac_error msg)-           StockClassError msg     -> bale_out msg-           CanDeriveStock gen_fn   -> go_for_it $ DerivSpecStock gen_fn-           CanDeriveAnyClass       -> go_for_it DerivSpecAnyClass--{--************************************************************************-*                                                                      *-            GeneralizedNewtypeDeriving and DerivingVia-*                                                                      *-************************************************************************--}---- | Derive an instance for a newtype.-mkNewTypeEqn :: DerivM EarlyDerivSpec-mkNewTypeEqn--- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...-  = do DerivEnv { denv_tc           = tycon-                , denv_rep_tc       = rep_tycon-                , denv_rep_tc_args  = rep_tc_args-                , denv_cls          = cls-                , denv_cls_tys      = cls_tys-                , denv_ctxt         = deriv_ctxt-                , denv_strat        = mb_strat } <- ask-       dflags <- getDynFlags--       let newtype_deriving  = xopt LangExt.GeneralizedNewtypeDeriving dflags-           deriveAnyClass    = xopt LangExt.DeriveAnyClass             dflags-           bale_out        = bale_out' newtype_deriving-           bale_out' b msg = do err <- derivingThingErrM b msg-                                lift $ failWithTc err--           non_std     = nonStdErr cls-           suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's"-                     <+> text "newtype-deriving extension"--           -- Here is the plan for newtype derivings.  We see-           --        newtype T a1...an = MkT (t ak+1...an)-           --          deriving (.., C s1 .. sm, ...)-           -- where t is a type,-           --       ak+1...an is a suffix of a1..an, and are all tyvars-           --       ak+1...an do not occur free in t, nor in the s1..sm-           --       (C s1 ... sm) is a  *partial applications* of class C-           --                      with the last parameter missing-           --       (T a1 .. ak) matches the kind of C's last argument-           --              (and hence so does t)-           -- The latter kind-check has been done by deriveTyData already,-           -- and tc_args are already trimmed-           ---           -- We generate the instance-           --       instance forall ({a1..ak} u fvs(s1..sm)).-           --                C s1 .. sm t => C s1 .. sm (T a1...ak)-           -- where T a1...ap is the partial application of-           --       the LHS of the correct kind and p >= k-           ---           --      NB: the variables below are:-           --              tc_tvs = [a1, ..., an]-           --              tyvars_to_keep = [a1, ..., ak]-           --              rep_ty = t ak .. an-           --              deriv_tvs = fvs(s1..sm) \ tc_tvs-           --              tys = [s1, ..., sm]-           --              rep_fn' = t-           ---           -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )-           -- We generate the instance-           --      instance Monad (ST s) => Monad (T s) where--           nt_eta_arity = newTyConEtadArity rep_tycon-                   -- For newtype T a b = MkT (S a a b), the TyCon-                   -- machinery already eta-reduces the representation type, so-                   -- we know that-                   --      T a ~ S a a-                   -- That's convenient here, because we may have to apply-                   -- it to fewer than its original complement of arguments--           -- Note [Newtype representation]-           -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-           -- Need newTyConRhs (*not* a recursive representation finder)-           -- to get the representation type. For example-           --      newtype B = MkB Int-           --      newtype A = MkA B deriving( Num )-           -- We want the Num instance of B, *not* the Num instance of Int,-           -- when making the Num instance of A!-           rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args--           --------------------------------------------------------------------           --  Figuring out whether we can only do this newtype-deriving thing--           -- See Note [Determining whether newtype-deriving is appropriate]-           might_be_newtype_derivable-              =  not (non_coercible_class cls)-              && eta_ok---            && not (isRecursiveTyCon tycon)      -- Note [Recursive newtypes]--           -- Check that eta reduction is OK-           eta_ok = rep_tc_args `lengthAtLeast` nt_eta_arity-             -- The newtype can be eta-reduced to match the number-             --     of type argument actually supplied-             --        newtype T a b = MkT (S [a] b) deriving( Monad )-             --     Here the 'b' must be the same in the rep type (S [a] b)-             --     And the [a] must not mention 'b'.  That's all handled-             --     by nt_eta_rity.--           cant_derive_err = ppUnless eta_ok  eta_msg-           eta_msg = text "cannot eta-reduce the representation type enough"--       MASSERT( cls_tys `lengthIs` (classArity cls - 1) )-       case mb_strat of-         Just StockStrategy    -> mk_eqn_stock    mk_originative_eqn bale_out-         Just AnyclassStrategy -> mk_eqn_anyclass mk_originative_eqn bale_out-         Just NewtypeStrategy  ->-           -- Since the user explicitly asked for GeneralizedNewtypeDeriving,-           -- we don't need to perform all of the checks we normally would,-           -- such as if the class being derived is known to produce ill-roled-           -- coercions (e.g., Traversable), since we can just derive the-           -- instance and let it error if need be.-           -- See Note [Determining whether newtype-deriving is appropriate]-           if eta_ok && newtype_deriving-             then mk_eqn_newtype rep_inst_ty-             else bale_out (cant_derive_err $$-                            if newtype_deriving then empty else suggest_gnd)-         Just (ViaStrategy via_ty) ->-           -- NB: For DerivingVia, we don't need to any eta-reduction checking,-           -- since the @via@ type is already "eta-reduced".-           mk_eqn_via via_ty-         Nothing-           | might_be_newtype_derivable-             && ((newtype_deriving && not deriveAnyClass)-                  || std_class_via_coercible cls)-          -> mk_eqn_newtype rep_inst_ty-           | otherwise-          -> case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys-                                                 tycon rep_tycon of-               StockClassError msg-                 -- There's a particular corner case where-                 ---                 -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are-                 --    both enabled at the same time-                 -- 2. We're deriving a particular stock derivable class-                 --    (such as Functor)-                 ---                 -- and the previous cases won't catch it. This fixes the bug-                 -- reported in Trac #10598.-                 | might_be_newtype_derivable && newtype_deriving-                -> mk_eqn_newtype rep_inst_ty-                 -- Otherwise, throw an error for a stock class-                 | might_be_newtype_derivable && not newtype_deriving-                -> bale_out (msg $$ suggest_gnd)-                 | otherwise-                -> bale_out msg--               -- Must use newtype deriving or DeriveAnyClass-               NonDerivableClass _msg-                 -- Too hard, even with newtype deriving-                 | newtype_deriving           -> bale_out cant_derive_err-                 -- Try newtype deriving!-                 -- Here we suggest GeneralizedNewtypeDeriving even in cases-                 -- where it may not be applicable. See Trac #9600.-                 | otherwise                  -> bale_out (non_std $$ suggest_gnd)--               -- DeriveAnyClass-               CanDeriveAnyClass -> do-                 -- If both DeriveAnyClass and GeneralizedNewtypeDeriving are-                 -- enabled, we take the diplomatic approach of defaulting to-                 -- DeriveAnyClass, but emitting a warning about the choice.-                 -- See Note [Deriving strategies]-                 when (newtype_deriving && deriveAnyClass) $-                   lift $ addWarnTc NoReason $ sep-                     [ text "Both DeriveAnyClass and"-                       <+> text "GeneralizedNewtypeDeriving are enabled"-                     , text "Defaulting to the DeriveAnyClass strategy"-                       <+> text "for instantiating" <+> ppr cls-                     , text "Use DerivingStrategies to pick"-                       <+> text "a different strategy"-                      ]-                 mk_originative_eqn DerivSpecAnyClass-               -- CanDeriveStock-               CanDeriveStock gen_fn -> mk_originative_eqn $-                                        DerivSpecStock gen_fn--{--Note [Recursive newtypes]-~~~~~~~~~~~~~~~~~~~~~~~~~-Newtype deriving works fine, even if the newtype is recursive.-e.g.    newtype S1 = S1 [T1 ()]-        newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )-Remember, too, that type families are currently (conservatively) given-a recursive flag, so this also allows newtype deriving to work-for type famillies.--We used to exclude recursive types, because we had a rather simple-minded way of generating the instance decl:-   newtype A = MkA [A]-   instance Eq [A] => Eq A      -- Makes typechecker loop!-But now we require a simple context, so it's ok.--Note [Determining whether newtype-deriving is appropriate]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we see-  newtype NT = MkNT Foo-    deriving C-we have to decide how to perform the deriving. Do we do newtype deriving,-or do we do normal deriving? In general, we prefer to do newtype deriving-wherever possible. So, we try newtype deriving unless there's a glaring-reason not to.--"Glaring reasons not to" include trying to derive a class for which a-coercion-based instance doesn't make sense. These classes are listed in-the definition of non_coercible_class. They include Show (since it must-show the name of the datatype) and Traversable (since a coercion-based-Traversable instance is ill-roled).--However, non_coercible_class is ignored if the user explicitly requests-to derive an instance with GeneralizedNewtypeDeriving using the newtype-deriving strategy. In such a scenario, GHC will unquestioningly try to-derive the instance via coercions (even if the final generated code is-ill-roled!). See Note [Deriving strategies].--Note that newtype deriving might fail, even after we commit to it. This-is because the derived instance uses `coerce`, which must satisfy its-`Coercible` constraint. This is different than other deriving scenarios,-where we're sure that the resulting instance will type-check.--Note [GND and associated type families]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's possible to use GeneralizedNewtypeDeriving (GND) to derive instances for-classes with associated type families. A general recipe is:--    class C x y z where-      type T y z x-      op :: x -> [y] -> z--    newtype N a = MkN <rep-type> deriving( C )--    =====>--    instance C x y <rep-type> => C x y (N a) where-      type T y (N a) x = T y <rep-type> x-      op = coerce (op :: x -> [y] -> <rep-type>)--However, we must watch out for three things:--(a) The class must not contain any data families. If it did, we'd have to-    generate a fresh data constructor name for the derived data family-    instance, and it's not clear how to do this.--(b) Each associated type family's type variables must mention the last type-    variable of the class. As an example, you wouldn't be able to use GND to-    derive an instance of this class:--      class C a b where-        type T a--    But you would be able to derive an instance of this class:--      class C a b where-        type T b--    The difference is that in the latter T mentions the last parameter of C-    (i.e., it mentions b), but the former T does not. If you tried, e.g.,--      newtype Foo x = Foo x deriving (C a)--    with the former definition of C, you'd end up with something like this:--      instance C a (Foo x) where-        type T a = T ???--    This T family instance doesn't mention the newtype (or its representation-    type) at all, so we disallow such constructions with GND.--(c) UndecidableInstances might need to be enabled. Here's a case where it is-    most definitely necessary:--      class C a where-        type T a-      newtype Loop = Loop MkLoop deriving C--      =====>--      instance C Loop where-        type T Loop = T Loop--    Obviously, T Loop would send the typechecker into a loop. Unfortunately,-    you might even need UndecidableInstances even in cases where the-    typechecker would be guaranteed to terminate. For example:--      instance C Int where-        type C Int = Int-      newtype MyInt = MyInt Int deriving C--      =====>--      instance C MyInt where-        type T MyInt = T Int--    GHC's termination checker isn't sophisticated enough to conclude that the-    definition of T MyInt terminates, so UndecidableInstances is required.--(d) For the time being, we do not allow the last type variable of the class to-    appear in a /kind/ of an associated type family definition. For instance:--    class C a where-      type T1 a        -- OK-      type T2 (x :: a) -- Illegal: a appears in the kind of x-      type T3 y :: a   -- Illegal: a appears in the kind of (T3 y)--    The reason we disallow this is because our current approach to deriving-    associated type family instances—i.e., by unwrapping the newtype's type-    constructor as shown above—is ill-equipped to handle the scenario when-    the last type variable appears as an implicit argument. In the worst case,-    allowing the last variable to appear in a kind can result in improper Core-    being generated (see #14728).--    There is hope for this feature being added some day, as one could-    conceivably take a newtype axiom (which witnesses a coercion between a-    newtype and its representation type) at lift that through each associated-    type at the Core level. See #14728, comment:3 for a sketch of how this-    might work. Until then, we disallow this featurette wholesale.--The same criteria apply to DerivingVia.--************************************************************************-*                                                                      *-\subsection[TcDeriv-normal-binds]{Bindings for the various classes}-*                                                                      *-************************************************************************--After all the trouble to figure out the required context for the-derived instance declarations, all that's left is to chug along to-produce them.  They will then be shoved into @tcInstDecls2@, which-will do all its usual business.--There are lots of possibilities for code to generate.  Here are-various general remarks.--PRINCIPLES:-\begin{itemize}-\item-We want derived instances of @Eq@ and @Ord@ (both v common) to be-``you-couldn't-do-better-by-hand'' efficient.--\item-Deriving @Show@---also pretty common--- should also be reasonable good code.--\item-Deriving for the other classes isn't that common or that big a deal.-\end{itemize}--PRAGMATICS:--\begin{itemize}-\item-Deriving @Ord@ is done mostly with the 1.3 @compare@ method.--\item-Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.--\item-We {\em normally} generate code only for the non-defaulted methods;-there are some exceptions for @Eq@ and (especially) @Ord@...--\item-Sometimes we use a @_con2tag_<tycon>@ function, which returns a data-constructor's numeric (@Int#@) tag.  These are generated by-@gen_tag_n_con_binds@, and the heuristic for deciding if one of-these is around is given by @hasCon2TagFun@.--The examples under the different sections below will make this-clearer.--\item-Much less often (really just for deriving @Ix@), we use a-@_tag2con_<tycon>@ function.  See the examples.--\item-We use the renamer!!!  Reason: we're supposed to be-producing @LHsBinds Name@ for the methods, but that means-producing correctly-uniquified code on the fly.  This is entirely-possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.-So, instead, we produce @MonoBinds RdrName@ then heave 'em through-the renamer.  What a great hack!-\end{itemize}--}---- Generate the InstInfo for the required instance paired with the---   *representation* tycon for that instance,--- plus any auxiliary bindings required------ Representation tycons differ from the tycon in the instance signature in--- case of instances for indexed families.----genInst :: DerivSpec theta-        -> TcM (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])--- We must use continuation-returning style here to get the order in which we--- typecheck family instances and derived instances right.--- See Note [Staging of tcDeriving]-genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon-                 , ds_mechanism = mechanism, ds_tys = tys-                 , ds_cls = clas, ds_loc = loc-                 , ds_standalone_wildcard = wildcard })-  = do (meth_binds, deriv_stuff, unusedNames)-         <- set_span_and_ctxt $-            genDerivStuff mechanism loc clas rep_tycon tys tvs-       let mk_inst_info theta = set_span_and_ctxt $ do-             inst_spec <- newDerivClsInst theta spec-             doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism-             traceTc "newder" (ppr inst_spec)-             return $ InstInfo-                       { iSpec   = inst_spec-                       , iBinds  = InstBindings-                                     { ib_binds = meth_binds-                                     , ib_tyvars = map Var.varName tvs-                                     , ib_pragmas = []-                                     , ib_extensions = extensions-                                     , ib_derived = True } }-       return (mk_inst_info, deriv_stuff, unusedNames)-  where-    extensions :: [LangExt.Extension]-    extensions-      | isDerivSpecNewtype mechanism || isDerivSpecVia mechanism-        -- Both these flags are needed for higher-rank uses of coerce-        -- See Note [Newtype-deriving instances] in TcGenDeriv-      = [LangExt.ImpredicativeTypes, LangExt.RankNTypes]-      | otherwise-      = []--    set_span_and_ctxt :: TcM a -> TcM a-    set_span_and_ctxt = setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys)--doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM ()-doDerivInstErrorChecks1 mechanism = do-    DerivEnv { denv_tc      = tc-             , denv_rep_tc  = rep_tc } <- ask-    standalone <- isStandaloneDeriv-    let anyclass_strategy = isDerivSpecAnyClass mechanism-        via_strategy      = isDerivSpecVia mechanism-        bale_out msg = do err <- derivingThingErrMechanism mechanism msg-                          lift $ failWithTc err--    -- For standalone deriving, check that all the data constructors are in-    -- scope...-    rdr_env <- lift getGlobalRdrEnv-    let data_con_names = map dataConName (tyConDataCons rep_tc)-        hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&-                           (isAbstractTyCon rep_tc ||-                            any not_in_scope data_con_names)-        not_in_scope dc  = isNothing (lookupGRE_Name rdr_env dc)--    lift $ addUsedDataCons rdr_env rep_tc--    -- ...however, we don't perform this check if we're using DeriveAnyClass,-    -- since it doesn't generate any code that requires use of a data-    -- constructor. Nor do we perform this check with @deriving via@, as it-    -- doesn't explicitly require the constructors to be in scope.-    unless (anyclass_strategy || via_strategy-            || not standalone || not hidden_data_cons) $-           bale_out $ derivingHiddenErr tc--doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan-                        -> DerivSpecMechanism -> TcM ()-doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism-  = do { traceTc "doDerivInstErrorChecks2" (ppr clas_inst)-       ; dflags <- getDynFlags-       ; xpartial_sigs <- xoptM LangExt.PartialTypeSignatures-       ; wpartial_sigs <- woptM Opt_WarnPartialTypeSignatures--         -- Error if PartialTypeSignatures isn't enabled when a user tries-         -- to write @deriving instance _ => Eq (Foo a)@. Or, if that-         -- extension is enabled, give a warning if -Wpartial-type-signatures-         -- is enabled.-       ; case wildcard of-           Nothing -> pure ()-           Just span -> setSrcSpan span $ do-             checkTc xpartial_sigs (hang partial_sig_msg 2 pts_suggestion)-             warnTc (Reason Opt_WarnPartialTypeSignatures)-                    wpartial_sigs partial_sig_msg--         -- Check for Generic instances that are derived with an exotic-         -- deriving strategy like DAC-         -- See Note [Deriving strategies]-       ; when (exotic_mechanism && className clas `elem` genericClassNames) $-         do { failIfTc (safeLanguageOn dflags) gen_inst_err-            ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } }-  where-    exotic_mechanism = not $ isDerivSpecStock mechanism--    partial_sig_msg = text "Found type wildcard" <+> quotes (char '_')-                  <+> text "standing for" <+> quotes (pprTheta theta)--    pts_suggestion-      = text "To use the inferred type, enable PartialTypeSignatures"--    gen_inst_err = text "Generic instances can only be derived in"-               <+> text "Safe Haskell using the stock strategy."--genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class-              -> TyCon -> [Type] -> [TyVar]-              -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])-genDerivStuff mechanism loc clas tycon inst_tys tyvars-  = case mechanism of-      -- See Note [Bindings for Generalised Newtype Deriving]-      DerivSpecNewtype rhs_ty -> gen_newtype_or_via rhs_ty--      -- Try a stock deriver-      DerivSpecStock gen_fn -> gen_fn loc tycon inst_tys--      -- Try DeriveAnyClass-      DerivSpecAnyClass -> do-        let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)-            mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env-        dflags <- getDynFlags-        tyfam_insts <--          -- canDeriveAnyClass should ensure that this code can't be reached-          -- unless -XDeriveAnyClass is enabled.-          ASSERT2( isValid (canDeriveAnyClass dflags)-                 , ppr "genDerivStuff: bad derived class" <+> ppr clas )-          mapM (tcATDefault loc mini_subst emptyNameSet)-               (classATItems clas)-        return ( emptyBag -- No method bindings are needed...-               , listToBag (map DerivFamInst (concat tyfam_insts))-               -- ...but we may need to generate binding for associated type-               -- family default instances.-               -- See Note [DeriveAnyClass and default family instances]-               , [] )--      -- Try DerivingVia-      DerivSpecVia via_ty -> gen_newtype_or_via via_ty-  where-    gen_newtype_or_via ty = do-      (binds, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty-      return (binds, faminsts, maybeToList unusedConName)--    unusedConName :: Maybe Name-    unusedConName-      | isDerivSpecNewtype mechanism-        -- See Note [Newtype deriving and unused constructors]-      = Just $ getName $ head $ tyConDataCons tycon-      | otherwise-      = Nothing--{--Note [Bindings for Generalised Newtype Deriving]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  class Eq a => C a where-     f :: a -> a-  newtype N a = MkN [a] deriving( C )-  instance Eq (N a) where ...--The 'deriving C' clause generates, in effect-  instance (C [a], Eq a) => C (N a) where-     f = coerce (f :: [a] -> [a])--This generates a cast for each method, but allows the superclasse to-be worked out in the usual way.  In this case the superclass (Eq (N-a)) will be solved by the explicit Eq (N a) instance.  We do *not*-create the superclasses by casting the superclass dictionaries for the-representation type.--See the paper "Safe zero-cost coercions for Haskell".--Note [DeriveAnyClass and default family instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When a class has a associated type family with a default instance, e.g.:--  class C a where-    type T a-    type T a = Char--then there are a couple of scenarios in which a user would expect T a to-default to Char. One is when an instance declaration for C is given without-an implementation for T:--  instance C Int--Another scenario in which this can occur is when the -XDeriveAnyClass extension-is used:--  data Example = Example deriving (C, Generic)--In the latter case, we must take care to check if C has any associated type-families with default instances, because -XDeriveAnyClass will never provide-an implementation for them. We "fill in" the default instances using the-tcATDefault function from TcClassDcl (which is also used in TcInstDcls to-handle the empty instance declaration case).--Note [Deriving strategies]-~~~~~~~~~~~~~~~~~~~~~~~~~~-GHC has a notion of deriving strategies, which allow the user to explicitly-request which approach to use when deriving an instance (enabled with the--XDerivingStrategies language extension). For more information, refer to the-original Trac ticket (#10598) or the associated wiki page:-https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DerivingStrategies--A deriving strategy can be specified in a deriving clause:--    newtype Foo = MkFoo Bar-      deriving newtype C--Or in a standalone deriving declaration:--    deriving anyclass instance C Foo---XDerivingStrategies also allows the use of multiple deriving clauses per data-declaration so that a user can derive some instance with one deriving strategy-and other instances with another deriving strategy. For example:--    newtype Baz = Baz Quux-      deriving          (Eq, Ord)-      deriving stock    (Read, Show)-      deriving newtype  (Num, Floating)-      deriving anyclass C--Currently, the deriving strategies are:--* stock: Have GHC implement a "standard" instance for a data type, if possible-  (e.g., Eq, Ord, Generic, Data, Functor, etc.)--* anyclass: Use -XDeriveAnyClass--* newtype: Use -XGeneralizedNewtypeDeriving--* via: Use -XDerivingVia--The latter two strategies (newtype and via) are referred to as the-"coerce-based" strategies, since they generate code that relies on the `coerce`-function. The former two strategies (stock and anyclass), in contrast, are-referred to as the "originative" strategies, since they create "original"-instances instead of "reusing" old instances (by way of `coerce`).--If an explicit deriving strategy is not given, GHC has an algorithm it uses to-determine which strategy it will actually use. The algorithm is quite long,-so it lives in the Haskell wiki at-https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DerivingStrategies-("The deriving strategy resolution algorithm" section).--Internally, GHC uses the DerivStrategy datatype to denote a user-requested-deriving strategy, and it uses the DerivSpecMechanism datatype to denote what-GHC will use to derive the instance after taking the above steps. In other-words, GHC will always settle on a DerivSpecMechnism, even if the user did not-ask for a particular DerivStrategy (using the algorithm linked to above).--Note [Deriving instances for classes themselves]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Much of the code in TcDeriv assumes that deriving only works on data types.-But this assumption doesn't hold true for DeriveAnyClass, since it's perfectly-reasonable to do something like this:--  {-# LANGUAGE DeriveAnyClass #-}-  class C1 (a :: Constraint) where-  class C2 where-  deriving instance C1 C2-    -- This is equivalent to `instance C1 C2`--If DeriveAnyClass isn't enabled in the code above (i.e., it defaults to stock-deriving), we throw a special error message indicating that DeriveAnyClass is-the only way to go. We don't bother throwing this error if an explicit 'stock'-or 'newtype' keyword is used, since both options have their own perfectly-sensible error messages in the case of the above code (as C1 isn't a stock-derivable class, and C2 isn't a newtype).--************************************************************************-*                                                                      *-\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}-*                                                                      *-************************************************************************--}--nonUnaryErr :: LHsSigType GhcRn -> SDoc-nonUnaryErr ct = quotes (ppr ct)-  <+> text "is not a unary constraint, as expected by a deriving clause"--nonStdErr :: Class -> SDoc-nonStdErr cls =-      quotes (ppr cls)-  <+> text "is not a stock derivable class (Eq, Show, etc.)"--gndNonNewtypeErr :: SDoc-gndNonNewtypeErr =-  text "GeneralizedNewtypeDeriving cannot be used on non-newtypes"--derivingNullaryErr :: MsgDoc-derivingNullaryErr = text "Cannot derive instances for nullary classes"--derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> MsgDoc-derivingKindErr tc cls cls_tys cls_kind enough_args-  = sep [ hang (text "Cannot derive well-kinded instance of form"-                      <+> quotes (pprClassPred cls cls_tys-                                    <+> parens (ppr tc <+> text "...")))-               2 gen1_suggestion-        , nest 2 (text "Class" <+> quotes (ppr cls)-                      <+> text "expects an argument of kind"-                      <+> quotes (pprKind cls_kind))-        ]-  where-    gen1_suggestion | cls `hasKey` gen1ClassKey && enough_args-                    = text "(Perhaps you intended to use PolyKinds)"-                    | otherwise = Outputable.empty--derivingViaKindErr :: Class -> Kind -> Type -> Kind -> MsgDoc-derivingViaKindErr cls cls_kind via_ty via_kind-  = hang (text "Cannot derive instance via" <+> quotes (pprType via_ty))-       2 (text "Class" <+> quotes (ppr cls)-               <+> text "expects an argument of kind"-               <+> quotes (pprKind cls_kind) <> char ','-      $+$ text "but" <+> quotes (pprType via_ty)-               <+> text "has kind" <+> quotes (pprKind via_kind))--derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc-derivingEtaErr cls cls_tys inst_ty-  = sep [text "Cannot eta-reduce to an instance of form",-         nest 2 (text "instance (...) =>"-                <+> pprClassPred cls (cls_tys ++ [inst_ty]))]--derivingThingErr :: Bool -> Class -> [Type] -> Type-                 -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc-derivingThingErr newtype_deriving cls cls_tys inst_ty mb_strat why-  = derivingThingErr' newtype_deriving cls cls_tys inst_ty mb_strat-                      (maybe empty derivStrategyName mb_strat) why--derivingThingErrM :: Bool -> MsgDoc -> DerivM MsgDoc-derivingThingErrM newtype_deriving why-  = do DerivEnv { denv_tc      = tc-                , denv_tc_args = tc_args-                , denv_cls     = cls-                , denv_cls_tys = cls_tys-                , denv_strat   = mb_strat } <- ask-       pure $ derivingThingErr newtype_deriving cls cls_tys-                               (mkTyConApp tc tc_args) mb_strat why--derivingThingErrMechanism :: DerivSpecMechanism -> MsgDoc -> DerivM MsgDoc-derivingThingErrMechanism mechanism why-  = do DerivEnv { denv_tc      = tc-                , denv_tc_args = tc_args-                , denv_cls     = cls-                , denv_cls_tys = cls_tys-                , denv_strat   = mb_strat } <- ask-       pure $ derivingThingErr' (isDerivSpecNewtype mechanism) cls cls_tys-                (mkTyConApp tc tc_args) mb_strat-                (derivStrategyName $ derivSpecMechanismToStrategy mechanism)-                why--derivingThingErr' :: Bool -> Class -> [Type] -> Type-                  -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc -> MsgDoc-derivingThingErr' newtype_deriving cls cls_tys inst_ty mb_strat strat_msg why-  = sep [(hang (text "Can't make a derived instance of")-             2 (quotes (ppr pred) <+> via_mechanism)-          $$ nest 2 extra) <> colon,-         nest 2 why]-  where-    strat_used = isJust mb_strat-    extra | not strat_used, newtype_deriving-          = text "(even with cunning GeneralizedNewtypeDeriving)"-          | otherwise = empty-    pred = mkClassPred cls (cls_tys ++ [inst_ty])+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TypeFamilies #-}++module TcDeriv ( tcDeriving, DerivInfo(..) ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Hs+import DynFlags++import TcRnMonad+import FamInst+import TcOrigin+import Predicate+import TcDerivInfer+import TcDerivUtils+import TcValidity( allDistinctTyVars )+import TcClassDcl( instDeclCtxt3, tcATDefault )+import TcEnv+import TcGenDeriv                       -- Deriv stuff+import TcValidity( checkValidInstHead )+import InstEnv+import Inst+import FamInstEnv+import TcHsType+import TyCoRep+import TyCoPpr    ( pprTyVars )++import RnNames( extendGlobalRdrEnvRn )+import RnBinds+import RnEnv+import RnUtils    ( bindLocalNamesFV )+import RnSource   ( addTcgDUs )+import Avail++import Unify( tcUnifyTy )+import Class+import Type+import ErrUtils+import DataCon+import Maybes+import RdrName+import Name+import NameSet+import TyCon+import TcType+import Var+import VarEnv+import VarSet+import PrelNames+import SrcLoc+import Util+import Outputable+import FastString+import Bag+import FV (fvVarList, unionFV, mkFVs)+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Data.List (partition, find)++{-+************************************************************************+*                                                                      *+                Overview+*                                                                      *+************************************************************************++Overall plan+~~~~~~~~~~~~+1.  Convert the decls (i.e. data/newtype deriving clauses,+    plus standalone deriving) to [EarlyDerivSpec]++2.  Infer the missing contexts for the InferTheta's++3.  Add the derived bindings, generating InstInfos+-}++data EarlyDerivSpec = InferTheta (DerivSpec [ThetaOrigin])+                    | GivenTheta (DerivSpec ThetaType)+        -- InferTheta ds => the context for the instance should be inferred+        --      In this case ds_theta is the list of all the sets of+        --      constraints needed, such as (Eq [a], Eq a), together with a+        --      suitable CtLoc to get good error messages.+        --      The inference process is to reduce this to a+        --      simpler form (e.g. Eq a)+        --+        -- GivenTheta ds => the exact context for the instance is supplied+        --                  by the programmer; it is ds_theta+        -- See Note [Inferring the instance context] in TcDerivInfer++splitEarlyDerivSpec :: [EarlyDerivSpec]+                    -> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])+splitEarlyDerivSpec [] = ([],[])+splitEarlyDerivSpec (InferTheta spec : specs) =+    case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs)+splitEarlyDerivSpec (GivenTheta spec : specs) =+    case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs)++instance Outputable EarlyDerivSpec where+  ppr (InferTheta spec) = ppr spec <+> text "(Infer)"+  ppr (GivenTheta spec) = ppr spec <+> text "(Given)"++{-+Note [Data decl contexts]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++        data (RealFloat a) => Complex a = !a :+ !a deriving( Read )++We will need an instance decl like:++        instance (Read a, RealFloat a) => Read (Complex a) where+          ...++The RealFloat in the context is because the read method for Complex is bound+to construct a Complex, and doing that requires that the argument type is+in RealFloat.++But this ain't true for Show, Eq, Ord, etc, since they don't construct+a Complex; they only take them apart.++Our approach: identify the offending classes, and add the data type+context to the instance decl.  The "offending classes" are++        Read, Enum?++FURTHER NOTE ADDED March 2002.  In fact, Haskell98 now requires that+pattern matching against a constructor from a data type with a context+gives rise to the constraints for that context -- or at least the thinned+version.  So now all classes are "offending".++Note [Newtype deriving]+~~~~~~~~~~~~~~~~~~~~~~~+Consider this:+    class C a b+    instance C [a] Char+    newtype T = T Char deriving( C [a] )++Notice the free 'a' in the deriving.  We have to fill this out to+    newtype T = T Char deriving( forall a. C [a] )++And then translate it to:+    instance C [a] Char => C [a] T where ...++Note [Unused constructors and deriving clauses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See #3221.  Consider+   data T = T1 | T2 deriving( Show )+Are T1 and T2 unused?  Well, no: the deriving clause expands to mention+both of them.  So we gather defs/uses from deriving just like anything else.++-}++-- | Stuff needed to process a datatype's `deriving` clauses+data DerivInfo = DerivInfo { di_rep_tc  :: TyCon+                             -- ^ The data tycon for normal datatypes,+                             -- or the *representation* tycon for data families+                           , di_scoped_tvs :: ![(Name,TyVar)]+                             -- ^ Variables that scope over the deriving clause.+                           , di_clauses :: [LHsDerivingClause GhcRn]+                           , di_ctxt    :: SDoc -- ^ error context+                           }++{-++************************************************************************+*                                                                      *+\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}+*                                                                      *+************************************************************************+-}++tcDeriving  :: [DerivInfo]       -- All `deriving` clauses+            -> [LDerivDecl GhcRn] -- All stand-alone deriving declarations+            -> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)+tcDeriving deriv_infos deriv_decls+  = recoverM (do { g <- getGblEnv+                 ; return (g, emptyBag, emptyValBindsOut)}) $+    do  { -- Fish the "deriving"-related information out of the TcEnv+          -- And make the necessary "equations".+          early_specs <- makeDerivSpecs deriv_infos deriv_decls+        ; traceTc "tcDeriving" (ppr early_specs)++        ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs+        ; insts1 <- mapM genInst given_specs+        ; insts2 <- mapM genInst infer_specs++        ; dflags <- getDynFlags++        ; let (_, deriv_stuff, fvs) = unzip3 (insts1 ++ insts2)+        ; loc <- getSrcSpanM+        ; let (binds, famInsts) = genAuxBinds dflags loc+                                    (unionManyBags deriv_stuff)++        ; let mk_inst_infos1 = map fstOf3 insts1+        ; inst_infos1 <- apply_inst_infos mk_inst_infos1 given_specs++          -- We must put all the derived type family instances (from both+          -- infer_specs and given_specs) in the local instance environment+          -- before proceeding, or else simplifyInstanceContexts might+          -- get stuck if it has to reason about any of those family instances.+          -- See Note [Staging of tcDeriving]+        ; tcExtendLocalFamInstEnv (bagToList famInsts) $+          -- NB: only call tcExtendLocalFamInstEnv once, as it performs+          -- validity checking for all of the family instances you give it.+          -- If the family instances have errors, calling it twice will result+          -- in duplicate error messages!++     do {+        -- the stand-alone derived instances (@inst_infos1@) are used when+        -- inferring the contexts for "deriving" clauses' instances+        -- (@infer_specs@)+        ; final_specs <- extendLocalInstEnv (map iSpec inst_infos1) $+                         simplifyInstanceContexts infer_specs++        ; let mk_inst_infos2 = map fstOf3 insts2+        ; inst_infos2 <- apply_inst_infos mk_inst_infos2 final_specs+        ; let inst_infos = inst_infos1 ++ inst_infos2++        ; (inst_info, rn_binds, rn_dus) <- renameDeriv inst_infos binds++        ; unless (isEmptyBag inst_info) $+             liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"+                        (ddump_deriving inst_info rn_binds famInsts))++        ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info))+                                          getGblEnv+        ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ concat fvs)+        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } }+  where+    ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn+                   -> Bag FamInst             -- ^ Rep type family instances+                   -> SDoc+    ddump_deriving inst_infos extra_binds repFamInsts+      =    hang (text "Derived class instances:")+              2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))+                 $$ ppr extra_binds)+        $$ hangP "Derived type family instances:"+             (vcat (map pprRepTy (bagToList repFamInsts)))++    hangP s x = text "" $$ hang (ptext (sLit s)) 2 x++    -- Apply the suspended computations given by genInst calls.+    -- See Note [Staging of tcDeriving]+    apply_inst_infos :: [ThetaType -> TcM (InstInfo GhcPs)]+                     -> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs]+    apply_inst_infos = zipWithM (\f ds -> f (ds_theta ds))++-- Prints the representable type family instance+pprRepTy :: FamInst -> SDoc+pprRepTy fi@(FamInst { fi_tys = lhs })+  = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+>+      equals <+> ppr rhs+  where rhs = famInstRHS fi++renameDeriv :: [InstInfo GhcPs]+            -> Bag (LHsBind GhcPs, LSig GhcPs)+            -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)+renameDeriv inst_infos bagBinds+  = discardWarnings $+    -- Discard warnings about unused bindings etc+    setXOptM LangExt.EmptyCase $+    -- Derived decls (for empty types) can have+    --    case x of {}+    setXOptM LangExt.ScopedTypeVariables $+    setXOptM LangExt.KindSignatures $+    -- Derived decls (for newtype-deriving) can use ScopedTypeVariables &+    -- KindSignatures+    setXOptM LangExt.TypeApplications $+    -- GND/DerivingVia uses TypeApplications in generated code+    -- (See Note [Newtype-deriving instances] in TcGenDeriv)+    unsetXOptM LangExt.RebindableSyntax $+    -- See Note [Avoid RebindableSyntax when deriving]+    setXOptM LangExt.TemplateHaskellQuotes $+    -- DeriveLift makes uses of quotes+    do  {+        -- Bring the extra deriving stuff into scope+        -- before renaming the instances themselves+        ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))+        ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds+        ; let aux_val_binds = ValBinds noExtField aux_binds (bagToList aux_sigs)+        ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds+        ; let bndrs = collectHsValBinders rn_aux_lhs+        ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ;+        ; setEnvs envs $+    do  { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs+        ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos+        ; return (listToBag rn_inst_infos, rn_aux,+                  dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }++  where+    rn_inst_info :: InstInfo GhcPs -> TcM (InstInfo GhcRn, FreeVars)+    rn_inst_info+      inst_info@(InstInfo { iSpec = inst+                          , iBinds = InstBindings+                            { ib_binds = binds+                            , ib_tyvars = tyvars+                            , ib_pragmas = sigs+                            , ib_extensions = exts -- Only for type-checking+                            , ib_derived = sa } })+        =  ASSERT( null sigs )+           bindLocalNamesFV tyvars $+           do { (rn_binds,_, fvs) <- rnMethodBinds False (is_cls_nm inst) [] binds []+              ; let binds' = InstBindings { ib_binds = rn_binds+                                          , ib_tyvars = tyvars+                                          , ib_pragmas = []+                                          , ib_extensions = exts+                                          , ib_derived = sa }+              ; return (inst_info { iBinds = binds' }, fvs) }++{-+Note [Staging of tcDeriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here's a tricky corner case for deriving (adapted from #2721):++    class C a where+      type T a+      foo :: a -> T a++    instance C Int where+      type T Int = Int+      foo = id++    newtype N = N Int deriving C++This will produce an instance something like this:++    instance C N where+      type T N = T Int+      foo = coerce (foo :: Int -> T Int) :: N -> T N++We must be careful in order to typecheck this code. When determining the+context for the instance (in simplifyInstanceContexts), we need to determine+that T N and T Int have the same representation, but to do that, the T N+instance must be in the local family instance environment. Otherwise, GHC+would be unable to conclude that T Int is representationally equivalent to+T Int, and simplifyInstanceContexts would get stuck.++Previously, tcDeriving would defer adding any derived type family instances to+the instance environment until the very end, which meant that+simplifyInstanceContexts would get called without all the type family instances+it needed in the environment in order to properly simplify instance like+the C N instance above.++To avoid this scenario, we carefully structure the order of events in+tcDeriving. We first call genInst on the standalone derived instance specs and+the instance specs obtained from deriving clauses. Note that the return type of+genInst is a triple:++    TcM (ThetaType -> TcM (InstInfo RdrName), BagDerivStuff, Maybe Name)++The type family instances are in the BagDerivStuff. The first field of the+triple is a suspended computation which, given an instance context, produces+the rest of the instance. The fact that it is suspended is important, because+right now, we don't have ThetaTypes for the instances that use deriving clauses+(only the standalone-derived ones).++Now we can can collect the type family instances and extend the local instance+environment. At this point, it is safe to run simplifyInstanceContexts on the+deriving-clause instance specs, which gives us the ThetaTypes for the+deriving-clause instances. Now we can feed all the ThetaTypes to the+suspended computations and obtain our InstInfos, at which point+tcDeriving is done.++An alternative design would be to split up genInst so that the+family instances are generated separately from the InstInfos. But this would+require carving up a lot of the GHC deriving internals to accommodate the+change. On the other hand, we can keep all of the InstInfo and type family+instance logic together in genInst simply by converting genInst to+continuation-returning style, so we opt for that route.++Note [Why we don't pass rep_tc into deriveTyData]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Down in the bowels of mk_deriv_inst_tys_maybe, we need to convert the fam_tc+back into the rep_tc by means of a lookup. And yet we have the rep_tc right+here! Why look it up again? Answer: it's just easier this way.+We drop some number of arguments from the end of the datatype definition+in deriveTyData. The arguments are dropped from the fam_tc.+This action may drop a *different* number of arguments+passed to the rep_tc, depending on how many free variables, etc., the+dropped patterns have.++Also, this technique carries over the kind substitution from deriveTyData+nicely.++Note [Avoid RebindableSyntax when deriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The RebindableSyntax extension interacts awkwardly with the derivation of+any stock class whose methods require the use of string literals. The Show+class is a simple example (see #12688):++  {-# LANGUAGE RebindableSyntax, OverloadedStrings #-}+  newtype Text = Text String+  fromString :: String -> Text+  fromString = Text++  data Foo = Foo deriving Show++This will generate code to the effect of:++  instance Show Foo where+    showsPrec _ Foo = showString "Foo"++But because RebindableSyntax and OverloadedStrings are enabled, the "Foo"+string literal is now of type Text, not String, which showString doesn't+accept! This causes the generated Show instance to fail to typecheck.++To avoid this kind of scenario, we simply turn off RebindableSyntax entirely+in derived code.++************************************************************************+*                                                                      *+                From HsSyn to DerivSpec+*                                                                      *+************************************************************************++@makeDerivSpecs@ fishes around to find the info about needed derived instances.+-}++makeDerivSpecs :: [DerivInfo]+               -> [LDerivDecl GhcRn]+               -> TcM [EarlyDerivSpec]+makeDerivSpecs deriv_infos deriv_decls+  = do  { eqns1 <- sequenceA+                     [ deriveClause rep_tc scoped_tvs dcs preds err_ctxt+                     | DerivInfo { di_rep_tc = rep_tc+                                 , di_scoped_tvs = scoped_tvs+                                 , di_clauses = clauses+                                 , di_ctxt = err_ctxt } <- deriv_infos+                     , L _ (HsDerivingClause { deriv_clause_strategy = dcs+                                             , deriv_clause_tys = L _ preds })+                         <- clauses+                     ]+        ; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls+        ; return $ concat eqns1 ++ catMaybes eqns2 }++------------------------------------------------------------------+-- | Process the derived classes in a single @deriving@ clause.+deriveClause :: TyCon+             -> [(Name, TcTyVar)]  -- Scoped type variables taken from tcTyConScopedTyVars+                                   -- See Note [Scoped tyvars in a TcTyCon] in types/TyCon+             -> Maybe (LDerivStrategy GhcRn)+             -> [LHsSigType GhcRn] -> SDoc+             -> TcM [EarlyDerivSpec]+deriveClause rep_tc scoped_tvs mb_lderiv_strat deriv_preds err_ctxt+  = addErrCtxt err_ctxt $ do+      traceTc "deriveClause" $ vcat+        [ text "tvs"             <+> ppr tvs+        , text "scoped_tvs"      <+> ppr scoped_tvs+        , text "tc"              <+> ppr tc+        , text "tys"             <+> ppr tys+        , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat ]+      tcExtendNameTyVarEnv scoped_tvs $ do+        (mb_lderiv_strat', via_tvs) <- tcDerivStrategy mb_lderiv_strat+        tcExtendTyVarEnv via_tvs $+        -- Moreover, when using DerivingVia one can bind type variables in+        -- the `via` type as well, so these type variables must also be+        -- brought into scope.+          mapMaybeM (derivePred tc tys mb_lderiv_strat' via_tvs) deriv_preds+          -- After typechecking the `via` type once, we then typecheck all+          -- of the classes associated with that `via` type in the+          -- `deriving` clause.+          -- See also Note [Don't typecheck too much in DerivingVia].+  where+    tvs = tyConTyVars rep_tc+    (tc, tys) = case tyConFamInstSig_maybe rep_tc of+                        -- data family:+                  Just (fam_tc, pats, _) -> (fam_tc, pats)+      -- NB: deriveTyData wants the *user-specified*+      -- name. See Note [Why we don't pass rep_tc into deriveTyData]++                  _ -> (rep_tc, mkTyVarTys tvs)     -- datatype++-- | Process a single predicate in a @deriving@ clause.+--+-- This returns a 'Maybe' because the user might try to derive 'Typeable',+-- which is a no-op nowadays.+derivePred :: TyCon -> [Type] -> Maybe (LDerivStrategy GhcTc) -> [TyVar]+           -> LHsSigType GhcRn -> TcM (Maybe EarlyDerivSpec)+derivePred tc tys mb_lderiv_strat via_tvs deriv_pred =+  -- We carefully set up uses of recoverM to minimize error message+  -- cascades. See Note [Recovering from failures in deriving clauses].+  recoverM (pure Nothing) $+  setSrcSpan (getLoc (hsSigType deriv_pred)) $ do+    traceTc "derivePred" $ vcat+      [ text "tc"              <+> ppr tc+      , text "tys"             <+> ppr tys+      , text "deriv_pred"      <+> ppr deriv_pred+      , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat+      , text "via_tvs"         <+> ppr via_tvs ]+    (cls_tvs, cls, cls_tys, cls_arg_kinds) <- tcHsDeriv deriv_pred+    when (cls_arg_kinds `lengthIsNot` 1) $+      failWithTc (nonUnaryErr deriv_pred)+    let [cls_arg_kind] = cls_arg_kinds+        mb_deriv_strat = fmap unLoc mb_lderiv_strat+    if (className cls == typeableClassName)+    then do warnUselessTypeable+            return Nothing+    else let deriv_tvs = via_tvs ++ cls_tvs in+         Just <$> deriveTyData tc tys mb_deriv_strat+                               deriv_tvs cls cls_tys cls_arg_kind++{-+Note [Don't typecheck too much in DerivingVia]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following example:++  data D = ...+    deriving (A1 t, ..., A20 t) via T t++GHC used to be engineered such that it would typecheck the `deriving`+clause like so:++1. Take the first class in the clause (`A1`).+2. Typecheck the `via` type (`T t`) and bring its bound type variables+   into scope (`t`).+3. Typecheck the class (`A1`).+4. Move on to the next class (`A2`) and repeat the process until all+   classes have been typechecked.++This algorithm gets the job done most of the time, but it has two notable+flaws. One flaw is that it is wasteful: it requires that `T t` be typechecked+20 different times, once for each class in the `deriving` clause. This is+unnecessary because we only need to typecheck `T t` once in order to get+access to its bound type variable.++The other issue with this algorithm arises when there are no classes in the+`deriving` clause, like in the following example:++  data D2 = ...+    deriving () via Maybe Maybe++Because there are no classes, the algorithm above will simply do nothing.+As a consequence, GHC will completely miss the fact that `Maybe Maybe`+is ill-kinded nonsense (#16923).++To address both of these problems, GHC now uses this algorithm instead:++1. Typecheck the `via` type and bring its boudn type variables into scope.+2. Take the first class in the `deriving` clause.+3. Typecheck the class.+4. Move on to the next class and repeat the process until all classes have been+   typechecked.++This algorithm ensures that the `via` type is always typechecked, even if there+are no classes in the `deriving` clause. Moreover, it typecheck the `via` type+/exactly/ once and no more, even if there are multiple classes in the clause.++Note [Recovering from failures in deriving clauses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider what happens if you run this program (from #10684) without+DeriveGeneric enabled:++    data A = A deriving (Show, Generic)+    data B = B A deriving (Show)++Naturally, you'd expect GHC to give an error to the effect of:++    Can't make a derived instance of `Generic A':+      You need -XDeriveGeneric to derive an instance for this class++And *only* that error, since the other two derived Show instances appear to be+independent of this derived Generic instance. Yet GHC also used to give this+additional error on the program above:++    No instance for (Show A)+      arising from the 'deriving' clause of a data type declaration+    When deriving the instance for (Show B)++This was happening because when GHC encountered any error within a single+data type's set of deriving clauses, it would call recoverM and move on+to the next data type's deriving clauses. One unfortunate consequence of+this design is that if A's derived Generic instance failed, its derived+Show instance would be skipped entirely, leading to the "No instance for+(Show A)" error cascade.++The solution to this problem is to push through uses of recoverM to the+level of the individual derived classes in a particular data type's set of+deriving clauses. That is, if you have:++    newtype C = C D+      deriving (E, F, G)++Then instead of processing instances E through M under the scope of a single+recoverM, as in the following pseudocode:++  recoverM (pure Nothing) $ mapM derivePred [E, F, G]++We instead use recoverM in each iteration of the loop:++  mapM (recoverM (pure Nothing) . derivePred) [E, F, G]++And then process each class individually, under its own recoverM scope. That+way, failure to derive one class doesn't cancel out other classes in the+same set of clause-derived classes.+-}++------------------------------------------------------------------+deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec)+-- Process a single standalone deriving declaration+--  e.g.   deriving instance Show a => Show (T a)+-- Rather like tcLocalInstDecl+--+-- This returns a Maybe because the user might try to derive Typeable, which is+-- a no-op nowadays.+deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode))+  = setSrcSpan loc                   $+    addErrCtxt (standaloneCtxt deriv_ty)  $+    do { traceTc "Standalone deriving decl for" (ppr deriv_ty)+       ; let ctxt = TcOrigin.InstDeclCtxt True+       ; traceTc "Deriving strategy (standalone deriving)" $+           vcat [ppr mb_lderiv_strat, ppr deriv_ty]+       ; (mb_lderiv_strat, via_tvs) <- tcDerivStrategy mb_lderiv_strat+       ; (cls_tvs, deriv_ctxt, cls, inst_tys)+           <- tcExtendTyVarEnv via_tvs $+              tcStandaloneDerivInstType ctxt deriv_ty+       ; let mb_deriv_strat = fmap unLoc mb_lderiv_strat+             tvs            = via_tvs ++ cls_tvs+         -- See Note [Unify kinds in deriving]+       ; (tvs', deriv_ctxt', inst_tys', mb_deriv_strat') <-+           case mb_deriv_strat of+             -- Perform an additional unification with the kind of the `via`+             -- type and the result of the previous kind unification.+             Just (ViaStrategy via_ty)+                  -- This unification must be performed on the last element of+                  -- inst_tys, but we have not yet checked for this property.+                  -- (This is done later in expectNonNullaryClsArgs). For now,+                  -- simply do nothing if inst_tys is empty, since+                  -- expectNonNullaryClsArgs will error later if this+                  -- is the case.+               |  Just inst_ty <- lastMaybe inst_tys+               -> do+               let via_kind     = tcTypeKind via_ty+                   inst_ty_kind = tcTypeKind inst_ty+                   mb_match     = tcUnifyTy inst_ty_kind via_kind++               checkTc (isJust mb_match)+                       (derivingViaKindErr cls inst_ty_kind+                                           via_ty via_kind)++               let Just kind_subst = mb_match+                   ki_subst_range  = getTCvSubstRangeFVs kind_subst+                   -- See Note [Unification of two kind variables in deriving]+                   unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst+                                        && not (v `elemVarSet` ki_subst_range))+                                          tvs+                   (subst, _)    = substTyVarBndrs kind_subst unmapped_tkvs+                   (final_deriv_ctxt, final_deriv_ctxt_tys)+                     = case deriv_ctxt of+                         InferContext wc -> (InferContext wc, [])+                         SupplyContext theta ->+                           let final_theta = substTheta subst theta+                           in (SupplyContext final_theta, final_theta)+                   final_inst_tys   = substTys subst inst_tys+                   final_via_ty     = substTy  subst via_ty+                   -- See Note [Floating `via` type variables]+                   final_tvs        = tyCoVarsOfTypesWellScoped $+                                      final_deriv_ctxt_tys ++ final_inst_tys+                                        ++ [final_via_ty]+               pure ( final_tvs, final_deriv_ctxt, final_inst_tys+                    , Just (ViaStrategy final_via_ty) )++             _ -> pure (tvs, deriv_ctxt, inst_tys, mb_deriv_strat)+       ; traceTc "Standalone deriving;" $ vcat+              [ text "tvs':" <+> ppr tvs'+              , text "mb_deriv_strat':" <+> ppr mb_deriv_strat'+              , text "deriv_ctxt':" <+> ppr deriv_ctxt'+              , text "cls:" <+> ppr cls+              , text "inst_tys':" <+> ppr inst_tys' ]+                -- C.f. TcInstDcls.tcLocalInstDecl1++       ; if className cls == typeableClassName+         then do warnUselessTypeable+                 return Nothing+         else Just <$> mkEqnHelp (fmap unLoc overlap_mode)+                                 tvs' cls inst_tys'+                                 deriv_ctxt' mb_deriv_strat' }+deriveStandalone (L _ (XDerivDecl nec)) = noExtCon nec++-- Typecheck the type in a standalone deriving declaration.+--+-- This may appear dense, but it's mostly huffing and puffing to recognize+-- the special case of a type with an extra-constraints wildcard context, e.g.,+--+--   deriving instance _ => Eq (Foo a)+--+-- If there is such a wildcard, we typecheck this as if we had written+-- @deriving instance Eq (Foo a)@, and return @'InferContext' ('Just' loc)@,+-- as the 'DerivContext', where loc is the location of the wildcard used for+-- error reporting. This indicates that we should infer the context as if we+-- were deriving Eq via a deriving clause+-- (see Note [Inferring the instance context] in TcDerivInfer).+--+-- If there is no wildcard, then proceed as normal, and instead return+-- @'SupplyContext' theta@, where theta is the typechecked context.+--+-- Note that this will never return @'InferContext' 'Nothing'@, as that can+-- only happen with @deriving@ clauses.+tcStandaloneDerivInstType+  :: UserTypeCtxt -> LHsSigWcType GhcRn+  -> TcM ([TyVar], DerivContext, Class, [Type])+tcStandaloneDerivInstType ctxt+    (HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = vars+                                       , hsib_body   = deriv_ty_body })})+  | (tvs, theta, rho) <- splitLHsSigmaTyInvis deriv_ty_body+  , L _ [wc_pred] <- theta+  , L wc_span (HsWildCardTy _) <- ignoreParens wc_pred+  = do dfun_ty <- tcHsClsInstType ctxt $+                  HsIB { hsib_ext = vars+                       , hsib_body+                           = L (getLoc deriv_ty_body) $+                             HsForAllTy { hst_fvf = ForallInvis+                                        , hst_bndrs = tvs+                                        , hst_xforall = noExtField+                                        , hst_body  = rho }}+       let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty+       pure (tvs, InferContext (Just wc_span), cls, inst_tys)+  | otherwise+  = do dfun_ty <- tcHsClsInstType ctxt deriv_ty+       let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty+       pure (tvs, SupplyContext theta, cls, inst_tys)++tcStandaloneDerivInstType _ (HsWC _ (XHsImplicitBndrs nec))+  = noExtCon nec+tcStandaloneDerivInstType _ (XHsWildCardBndrs nec)+  = noExtCon nec++warnUselessTypeable :: TcM ()+warnUselessTypeable+  = do { warn <- woptM Opt_WarnDerivingTypeable+       ; when warn $ addWarnTc (Reason Opt_WarnDerivingTypeable)+                   $ text "Deriving" <+> quotes (ppr typeableClassName) <+>+                     text "has no effect: all types now auto-derive Typeable" }++------------------------------------------------------------------+deriveTyData :: TyCon -> [Type] -- LHS of data or data instance+                    -- Can be a data instance, hence [Type] args+                    -- and in that case the TyCon is the /family/ tycon+             -> Maybe (DerivStrategy GhcTc) -- The optional deriving strategy+             -> [TyVar] -- The type variables bound by the derived class+             -> Class   -- The derived class+             -> [Type]  -- The derived class's arguments+             -> Kind    -- The function argument in the derived class's kind.+                        -- (e.g., if `deriving Functor`, this would be+                        -- `Type -> Type` since+                        -- `Functor :: (Type -> Type) -> Constraint`)+             -> TcM EarlyDerivSpec+-- The deriving clause of a data or newtype declaration+-- I.e. not standalone deriving+deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind+   = do {  -- Given data T a b c = ... deriving( C d ),+           -- we want to drop type variables from T so that (C d (T a)) is well-kinded+          let (arg_kinds, _)  = splitFunTys cls_arg_kind+              n_args_to_drop  = length arg_kinds+              n_args_to_keep  = length tc_args - n_args_to_drop+                                -- See Note [tc_args and tycon arity]+              (tc_args_to_keep, args_to_drop)+                              = splitAt n_args_to_keep tc_args+              inst_ty_kind    = tcTypeKind (mkTyConApp tc tc_args_to_keep)++              -- Match up the kinds, and apply the resulting kind substitution+              -- to the types.  See Note [Unify kinds in deriving]+              -- We are assuming the tycon tyvars and the class tyvars are distinct+              mb_match        = tcUnifyTy inst_ty_kind cls_arg_kind+              enough_args     = n_args_to_keep >= 0++        -- Check that the result really is well-kinded+        ; checkTc (enough_args && isJust mb_match)+                  (derivingKindErr tc cls cls_tys cls_arg_kind enough_args)++        ; let -- Returns a singleton-element list if using ViaStrategy and an+              -- empty list otherwise. Useful for free-variable calculations.+              deriv_strat_tys :: Maybe (DerivStrategy GhcTc) -> [Type]+              deriv_strat_tys = foldMap (foldDerivStrategy [] (:[]))++              propagate_subst kind_subst tkvs' cls_tys' tc_args' mb_deriv_strat'+                = (final_tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat)+                where+                  ki_subst_range  = getTCvSubstRangeFVs kind_subst+                  -- See Note [Unification of two kind variables in deriving]+                  unmapped_tkvs   = filter (\v -> v `notElemTCvSubst` kind_subst+                                         && not (v `elemVarSet` ki_subst_range))+                                           tkvs'+                  (subst, _)           = substTyVarBndrs kind_subst unmapped_tkvs+                  final_tc_args        = substTys subst tc_args'+                  final_cls_tys        = substTys subst cls_tys'+                  final_mb_deriv_strat = fmap (mapDerivStrategy (substTy subst))+                                              mb_deriv_strat'+                  -- See Note [Floating `via` type variables]+                  final_tkvs           = tyCoVarsOfTypesWellScoped $+                                         final_cls_tys ++ final_tc_args+                                           ++ deriv_strat_tys final_mb_deriv_strat++        ; let tkvs = scopedSort $ fvVarList $+                     unionFV (tyCoFVsOfTypes tc_args_to_keep)+                             (FV.mkFVs deriv_tvs)+              Just kind_subst = mb_match+              (tkvs', cls_tys', tc_args', mb_deriv_strat')+                = propagate_subst kind_subst tkvs cls_tys+                                  tc_args_to_keep mb_deriv_strat++          -- See Note [Unify kinds in deriving]+        ; (final_tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) <-+            case mb_deriv_strat' of+              -- Perform an additional unification with the kind of the `via`+              -- type and the result of the previous kind unification.+              Just (ViaStrategy via_ty) -> do+                let via_kind = tcTypeKind via_ty+                    inst_ty_kind+                              = tcTypeKind (mkTyConApp tc tc_args')+                    via_match = tcUnifyTy inst_ty_kind via_kind++                checkTc (isJust via_match)+                        (derivingViaKindErr cls inst_ty_kind via_ty via_kind)++                let Just via_subst = via_match+                pure $ propagate_subst via_subst tkvs' cls_tys'+                                       tc_args' mb_deriv_strat'++              _ -> pure (tkvs', cls_tys', tc_args', mb_deriv_strat')++        ; traceTc "deriveTyData 1" $ vcat+            [ ppr final_mb_deriv_strat, pprTyVars deriv_tvs, ppr tc, ppr tc_args+            , pprTyVars (tyCoVarsOfTypesList tc_args)+            , ppr n_args_to_keep, ppr n_args_to_drop+            , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match+            , ppr final_tc_args, ppr final_cls_tys ]++        ; traceTc "deriveTyData 2" $ vcat+            [ ppr final_tkvs ]++        ; let final_tc_app   = mkTyConApp tc final_tc_args+              final_cls_args = final_cls_tys ++ [final_tc_app]+        ; checkTc (allDistinctTyVars (mkVarSet final_tkvs) args_to_drop) -- (a, b, c)+                  (derivingEtaErr cls final_cls_tys final_tc_app)+                -- Check that+                --  (a) The args to drop are all type variables; eg reject:+                --              data instance T a Int = .... deriving( Monad )+                --  (b) The args to drop are all *distinct* type variables; eg reject:+                --              class C (a :: * -> * -> *) where ...+                --              data instance T a a = ... deriving( C )+                --  (c) The type class args, or remaining tycon args,+                --      do not mention any of the dropped type variables+                --              newtype T a s = ... deriving( ST s )+                --              newtype instance K a a = ... deriving( Monad )+                --+                -- It is vital that the implementation of allDistinctTyVars+                -- expand any type synonyms.+                -- See Note [Eta-reducing type synonyms]++        ; checkValidInstHead DerivClauseCtxt cls final_cls_args+                -- Check that we aren't deriving an instance of a magical+                -- type like (~) or Coercible (#14916).++        ; spec <- mkEqnHelp Nothing final_tkvs cls final_cls_args+                            (InferContext Nothing) final_mb_deriv_strat+        ; traceTc "deriveTyData 3" (ppr spec)+        ; return spec }+++{- Note [tc_args and tycon arity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+You might wonder if we could use (tyConArity tc) at this point, rather+than (length tc_args).  But for data families the two can differ!  The+tc and tc_args passed into 'deriveTyData' come from 'deriveClause' which+in turn gets them from 'tyConFamInstSig_maybe' which in turn gets them+from DataFamInstTyCon:++| DataFamInstTyCon          -- See Note [Data type families]+      (CoAxiom Unbranched)+      TyCon   -- The family TyCon+      [Type]  -- Argument types (mentions the tyConTyVars of this TyCon)+              -- No shorter in length than the tyConTyVars of the family TyCon+              -- How could it be longer? See [Arity of data families] in FamInstEnv++Notice that the arg tys might not be the same as the family tycon arity+(= length tyConTyVars).++Note [Unify kinds in deriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#8534)+    data T a b = MkT a deriving( Functor )+    -- where Functor :: (*->*) -> Constraint++So T :: forall k. * -> k -> *.   We want to get+    instance Functor (T * (a:*)) where ...+Notice the '*' argument to T.++Moreover, as well as instantiating T's kind arguments, we may need to instantiate+C's kind args.  Consider (#8865):+  newtype T a b = MkT (Either a b) deriving( Category )+where+  Category :: forall k. (k -> k -> *) -> Constraint+We need to generate the instance+  instance Category * (Either a) where ...+Notice the '*' argument to Category.++So we need to+ * drop arguments from (T a b) to match the number of+   arrows in the (last argument of the) class;+ * and then *unify* kind of the remaining type against the+   expected kind, to figure out how to instantiate C's and T's+   kind arguments.++In the two examples,+ * we unify   kind-of( T k (a:k) ) ~ kind-of( Functor )+         i.e.      (k -> *) ~ (* -> *)   to find k:=*.+         yielding  k:=*++ * we unify   kind-of( Either ) ~ kind-of( Category )+         i.e.      (* -> * -> *)  ~ (k -> k -> k)+         yielding  k:=*++Now we get a kind substitution.  We then need to:++  1. Remove the substituted-out kind variables from the quantified kind vars++  2. Apply the substitution to the kinds of quantified *type* vars+     (and extend the substitution to reflect this change)++  3. Apply that extended substitution to the non-dropped args (types and+     kinds) of the type and class++Forgetting step (2) caused #8893:+  data V a = V [a] deriving Functor+  data P (x::k->*) (a:k) = P (x a) deriving Functor+  data C (x::k->*) (a:k) = C (V (P x a)) deriving Functor++When deriving Functor for P, we unify k to *, but we then want+an instance   $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*))+and similarly for C.  Notice the modified kind of x, both at binding+and occurrence sites.++This can lead to some surprising results when *visible* kind binder is+unified (in contrast to the above examples, in which only non-visible kind+binders were considered). Consider this example from #11732:++    data T k (a :: k) = MkT deriving Functor++Since unification yields k:=*, this results in a generated instance of:++    instance Functor (T *) where ...++which looks odd at first glance, since one might expect the instance head+to be of the form Functor (T k). Indeed, one could envision an alternative+generated instance of:++    instance (k ~ *) => Functor (T k) where++But this does not typecheck by design: kind equalities are not allowed to be+bound in types, only terms. But in essence, the two instance declarations are+entirely equivalent, since even though (T k) matches any kind k, the only+possibly value for k is *, since anything else is ill-typed. As a result, we can+just as comfortably use (T *).++Another way of thinking about is: deriving clauses often infer constraints.+For example:++    data S a = S a deriving Eq++infers an (Eq a) constraint in the derived instance. By analogy, when we+are deriving Functor, we might infer an equality constraint (e.g., k ~ *).+The only distinction is that GHC instantiates equality constraints directly+during the deriving process.++Another quirk of this design choice manifests when typeclasses have visible+kind parameters. Consider this code (also from #11732):++    class Cat k (cat :: k -> k -> *) where+      catId   :: cat a a+      catComp :: cat b c -> cat a b -> cat a c++    instance Cat * (->) where+      catId   = id+      catComp = (.)++    newtype Fun a b = Fun (a -> b) deriving (Cat k)++Even though we requested a derived instance of the form (Cat k Fun), the+kind unification will actually generate (Cat * Fun) (i.e., the same thing as if+the user wrote deriving (Cat *)).++What happens with DerivingVia, when you have yet another type? Consider:++  newtype Foo (a :: Type) = MkFoo (Proxy a)+    deriving Functor via Proxy++As before, we unify the kind of Foo (* -> *) with the kind of the argument to+Functor (* -> *). But that's not enough: the `via` type, Proxy, has the kind+(k -> *), which is more general than what we want. So we must additionally+unify (k -> *) with (* -> *).++Currently, all of this unification is implemented kludgily with the pure+unifier, which is rather tiresome. #14331 lays out a plan for how this+might be made cleaner.++Note [Unification of two kind variables in deriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As a special case of the Note above, it is possible to derive an instance of+a poly-kinded typeclass for a poly-kinded datatype. For example:++    class Category (cat :: k -> k -> *) where+    newtype T (c :: k -> k -> *) a b = MkT (c a b) deriving Category++This case is suprisingly tricky. To see why, let's write out what instance GHC+will attempt to derive (using -fprint-explicit-kinds syntax):++    instance Category k1 (T k2 c) where ...++GHC will attempt to unify k1 and k2, which produces a substitution (kind_subst)+that looks like [k2 :-> k1]. Importantly, we need to apply this substitution to+the type variable binder for c, since its kind is (k2 -> k2 -> *).++We used to accomplish this by doing the following:++    unmapped_tkvs = filter (`notElemTCvSubst` kind_subst) all_tkvs+    (subst, _)    = substTyVarBndrs kind_subst unmapped_tkvs++Where all_tkvs contains all kind variables in the class and instance types (in+this case, all_tkvs = [k1,k2]). But since kind_subst only has one mapping,+this results in unmapped_tkvs being [k1], and as a consequence, k1 gets mapped+to another kind variable in subst! That is, subst = [k2 :-> k1, k1 :-> k_new].+This is bad, because applying that substitution yields the following instance:++   instance Category k_new (T k1 c) where ...++In other words, keeping k1 in unmapped_tvks taints the substitution, resulting+in an ill-kinded instance (this caused #11837).++To prevent this, we need to filter out any variable from all_tkvs which either++1. Appears in the domain of kind_subst. notElemTCvSubst checks this.+2. Appears in the range of kind_subst. To do this, we compute the free+   variable set of the range of kind_subst with getTCvSubstRangeFVs, and check+   if a kind variable appears in that set.++Note [Eta-reducing type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+One can instantiate a type in a data family instance with a type synonym that+mentions other type variables:++  type Const a b = a+  data family Fam (f :: * -> *) (a :: *)+  newtype instance Fam f (Const a f) = Fam (f a) deriving Functor++It is also possible to define kind synonyms, and they can mention other types in+a datatype declaration. For example,++  type Const a b = a+  newtype T f (a :: Const * f) = T (f a) deriving Functor++When deriving, we need to perform eta-reduction analysis to ensure that none of+the eta-reduced type variables are mentioned elsewhere in the declaration. But+we need to be careful, because if we don't expand through the Const type+synonym, we will mistakenly believe that f is an eta-reduced type variable and+fail to derive Functor, even though the code above is correct (see #11416,+where this was first noticed). For this reason, we expand the type synonyms in+the eta-reduced types before doing any analysis.++Note [Floating `via` type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When generating a derived instance, it will be of the form:++  instance forall ???. C c_args (D d_args) where ...++To fill in ???, GHC computes the free variables of `c_args` and `d_args`.+`DerivingVia` adds an extra wrinkle to this formula, since we must also+include the variables bound by the `via` type when computing the binders+used to fill in ???. This might seem strange, since if a `via` type binds+any type variables, then in almost all scenarios it will appear free in+`c_args` or `d_args`. There are certain corner cases where this does not hold,+however, such as in the following example (adapted from #15831):++  newtype Age = MkAge Int+    deriving Eq via Const Int a++In this example, the `via` type binds the type variable `a`, but `a` appears+nowhere in `Eq Age`. Nevertheless, we include it in the generated instance:++  instance forall a. Eq Age where+    (==) = coerce @(Const Int a -> Const Int a -> Bool)+                  @(Age         -> Age         -> Bool)+                  (==)++The use of `forall a` is certainly required here, since the `a` in+`Const Int a` would not be in scope otherwise. This instance is somewhat+strange in that nothing in the instance head `Eq Age` ever determines what `a`+will be, so any code that uses this instance will invariably instantiate `a`+to be `Any`. We refer to this property of `a` as being a "floating" `via`+type variable. Programs with floating `via` type variables are the only known+class of program in which the `via` type quantifies type variables that aren't+mentioned in the instance head in the generated instance.++Fortunately, the choice to instantiate floating `via` type variables to `Any`+is one that is completely transparent to the user (since the instance will+work as expected regardless of what `a` is instantiated to), so we decide to+permit them. An alternative design would make programs with floating `via`+variables illegal, by requiring that every variable mentioned in the `via` type+is also mentioned in the data header or the derived class. That restriction+would require the user to pick a particular type (the choice does not matter);+for example:++  newtype Age = MkAge Int+    -- deriving Eq via Const Int a  -- Floating 'a'+    deriving Eq via Const Int ()    -- Choose a=()+    deriving Eq via Const Int Any   -- Choose a=Any++No expressiveness would be lost thereby, but stylistically it seems preferable+to allow a type variable to indicate "it doesn't matter".++Note that by quantifying the `a` in `forall a. Eq Age`, we are deferring the+work of instantiating `a` to `Any` at every use site of the instance. An+alternative approach would be to generate an instance that directly defaulted+to `Any`:++  instance Eq Age where+    (==) = coerce @(Const Int Any -> Const Int Any -> Bool)+                  @(Age           -> Age           -> Bool)+                  (==)++We do not implement this approach since it would require a nontrivial amount+of implementation effort to substitute `Any` for the floating `via` type+variables, and since the end result isn't distinguishable from the former+instance (at least from the user's perspective), the amount of engineering+required to obtain the latter instance just isn't worth it.+-}++mkEqnHelp :: Maybe OverlapMode+          -> [TyVar]+          -> Class -> [Type]+          -> DerivContext+               -- SupplyContext => context supplied (standalone deriving)+               -- InferContext  => context inferred (deriving on data decl, or+               --                  standalone deriving decl with a wildcard)+          -> Maybe (DerivStrategy GhcTc)+          -> TcRn EarlyDerivSpec+-- Make the EarlyDerivSpec for an instance+--      forall tvs. theta => cls (tys ++ [ty])+-- where the 'theta' is optional (that's the Maybe part)+-- Assumes that this declaration is well-kinded++mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do+  is_boot <- tcIsHsBootOrSig+  when is_boot $+       bale_out (text "Cannot derive instances in hs-boot files"+             $+$ text "Write an instance declaration instead")+  runReaderT mk_eqn deriv_env+  where+    deriv_env = DerivEnv { denv_overlap_mode = overlap_mode+                         , denv_tvs          = tvs+                         , denv_cls          = cls+                         , denv_inst_tys     = cls_args+                         , denv_ctxt         = deriv_ctxt+                         , denv_strat        = deriv_strat }++    bale_out msg = failWithTc $ derivingThingErr False cls cls_args deriv_strat msg++    mk_eqn :: DerivM EarlyDerivSpec+    mk_eqn = do+      DerivEnv { denv_inst_tys = cls_args+               , denv_strat    = mb_strat } <- ask+      case mb_strat of+        Just StockStrategy -> do+          (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args+          dit                <- expectAlgTyConApp cls_tys inst_ty+          mk_eqn_stock dit++        Just AnyclassStrategy -> mk_eqn_anyclass++        Just (ViaStrategy via_ty) -> do+          (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args+          mk_eqn_via cls_tys inst_ty via_ty++        Just NewtypeStrategy -> do+          (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args+          dit                <- expectAlgTyConApp cls_tys inst_ty+          unless (isNewTyCon (dit_rep_tc dit)) $+            derivingThingFailWith False gndNonNewtypeErr+          mkNewTypeEqn True dit++        Nothing -> mk_eqn_no_strategy++-- @expectNonNullaryClsArgs inst_tys@ checks if @inst_tys@ is non-empty.+-- If so, return @(init inst_tys, last inst_tys)@.+-- Otherwise, throw an error message.+-- See @Note [DerivEnv and DerivSpecMechanism]@ in "TcDerivUtils" for why this+-- property is important.+expectNonNullaryClsArgs :: [Type] -> DerivM ([Type], Type)+expectNonNullaryClsArgs inst_tys =+  maybe (derivingThingFailWith False derivingNullaryErr) pure $+  snocView inst_tys++-- @expectAlgTyConApp cls_tys inst_ty@ checks if @inst_ty@ is an application+-- of an algebraic type constructor. If so, return a 'DerivInstTys' consisting+-- of @cls_tys@ and the constituent pars of @inst_ty@.+-- Otherwise, throw an error message.+-- See @Note [DerivEnv and DerivSpecMechanism]@ in "TcDerivUtils" for why this+-- property is important.+expectAlgTyConApp :: [Type] -- All but the last argument to the class in a+                            -- derived instance+                  -> Type   -- The last argument to the class in a+                            -- derived instance+                  -> DerivM DerivInstTys+expectAlgTyConApp cls_tys inst_ty = do+  fam_envs <- lift tcGetFamInstEnvs+  case mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty of+    Nothing -> derivingThingFailWith False $+                   text "The last argument of the instance must be a"+               <+> text "data or newtype application"+    Just dit -> do expectNonDataFamTyCon dit+                   pure dit++-- @expectNonDataFamTyCon dit@ checks if @dit_rep_tc dit@ is a representation+-- type constructor for a data family instance, and if not,+-- throws an error message.+-- See @Note [DerivEnv and DerivSpecMechanism]@ in "TcDerivUtils" for why this+-- property is important.+expectNonDataFamTyCon :: DerivInstTys -> DerivM ()+expectNonDataFamTyCon (DerivInstTys { dit_tc      = tc+                                    , dit_tc_args = tc_args+                                    , dit_rep_tc  = rep_tc }) =+  -- If it's still a data family, the lookup failed; i.e no instance exists+  when (isDataFamilyTyCon rep_tc) $+    derivingThingFailWith False $+    text "No family instance for" <+> quotes (pprTypeApp tc tc_args)++mk_deriv_inst_tys_maybe :: FamInstEnvs+                        -> [Type] -> Type -> Maybe DerivInstTys+mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty =+  fmap lookup $ tcSplitTyConApp_maybe inst_ty+  where+    lookup :: (TyCon, [Type]) -> DerivInstTys+    lookup (tc, tc_args) =+      -- Find the instance of a data family+      -- Note [Looking up family instances for deriving]+      let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tc tc_args+      in DerivInstTys { dit_cls_tys     = cls_tys+                      , dit_tc          = tc+                      , dit_tc_args     = tc_args+                      , dit_rep_tc      = rep_tc+                      , dit_rep_tc_args = rep_tc_args }++{-+Note [Looking up family instances for deriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcLookupFamInstExact is an auxiliary lookup wrapper which requires+that looked-up family instances exist.  If called with a vanilla+tycon, the old type application is simply returned.++If we have+  data instance F () = ... deriving Eq+  data instance F () = ... deriving Eq+then tcLookupFamInstExact will be confused by the two matches;+but that can't happen because tcInstDecls1 doesn't call tcDeriving+if there are any overlaps.++There are two other things that might go wrong with the lookup.+First, we might see a standalone deriving clause+   deriving Eq (F ())+when there is no data instance F () in scope.++Note that it's OK to have+  data instance F [a] = ...+  deriving Eq (F [(a,b)])+where the match is not exact; the same holds for ordinary data types+with standalone deriving declarations.++Note [Deriving, type families, and partial applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When there are no type families, it's quite easy:++    newtype S a = MkS [a]+    -- :CoS :: S  ~ []  -- Eta-reduced++    instance Eq [a] => Eq (S a)         -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a)+    instance Monad [] => Monad S        -- by coercion sym (Monad :CoS)  : Monad [] ~ Monad S++When type familes are involved it's trickier:++    data family T a b+    newtype instance T Int a = MkT [a] deriving( Eq, Monad )+    -- :RT is the representation type for (T Int a)+    --  :Co:RT    :: :RT ~ []          -- Eta-reduced!+    --  :CoF:RT a :: T Int a ~ :RT a   -- Also eta-reduced!++    instance Eq [a] => Eq (T Int a)     -- easy by coercion+       -- d1 :: Eq [a]+       -- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a))++    instance Monad [] => Monad (T Int)  -- only if we can eta reduce???+       -- d1 :: Monad []+       -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT))++Note the need for the eta-reduced rule axioms.  After all, we can+write it out+    instance Monad [] => Monad (T Int)  -- only if we can eta reduce???+      return x = MkT [x]+      ... etc ...++See Note [Eta reduction for data families] in FamInstEnv++%************************************************************************+%*                                                                      *+                Deriving data types+*                                                                      *+************************************************************************+-}++-- Once the DerivSpecMechanism is known, we can finally produce an+-- EarlyDerivSpec from it.+mk_eqn_from_mechanism :: DerivSpecMechanism -> DerivM EarlyDerivSpec+mk_eqn_from_mechanism mechanism+  = do DerivEnv { denv_overlap_mode = overlap_mode+                , denv_tvs          = tvs+                , denv_cls          = cls+                , denv_inst_tys     = inst_tys+                , denv_ctxt         = deriv_ctxt } <- ask+       doDerivInstErrorChecks1 mechanism+       loc       <- lift getSrcSpanM+       dfun_name <- lift $ newDFunName cls inst_tys loc+       case deriv_ctxt of+        InferContext wildcard ->+          do { (inferred_constraints, tvs', inst_tys')+                 <- inferConstraints mechanism+             ; return $ InferTheta $ DS+                   { ds_loc = loc+                   , ds_name = dfun_name, ds_tvs = tvs'+                   , ds_cls = cls, ds_tys = inst_tys'+                   , ds_theta = inferred_constraints+                   , ds_overlap = overlap_mode+                   , ds_standalone_wildcard = wildcard+                   , ds_mechanism = mechanism } }++        SupplyContext theta ->+            return $ GivenTheta $ DS+                   { ds_loc = loc+                   , ds_name = dfun_name, ds_tvs = tvs+                   , ds_cls = cls, ds_tys = inst_tys+                   , ds_theta = theta+                   , ds_overlap = overlap_mode+                   , ds_standalone_wildcard = Nothing+                   , ds_mechanism = mechanism }++mk_eqn_stock :: DerivInstTys -- Information about the arguments to the class+             -> DerivM EarlyDerivSpec+mk_eqn_stock dit@(DerivInstTys { dit_cls_tys = cls_tys+                               , dit_tc      = tc+                               , dit_rep_tc  = rep_tc })+  = do DerivEnv { denv_cls  = cls+                , denv_ctxt = deriv_ctxt } <- ask+       dflags <- getDynFlags+       case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys+                                           tc rep_tc of+         CanDeriveStock gen_fn -> mk_eqn_from_mechanism $+                                  DerivSpecStock { dsm_stock_dit    = dit+                                                 , dsm_stock_gen_fn = gen_fn }+         StockClassError msg   -> derivingThingFailWith False msg+         _                     -> derivingThingFailWith False (nonStdErr cls)++mk_eqn_anyclass :: DerivM EarlyDerivSpec+mk_eqn_anyclass+  = do dflags <- getDynFlags+       case canDeriveAnyClass dflags of+         IsValid      -> mk_eqn_from_mechanism DerivSpecAnyClass+         NotValid msg -> derivingThingFailWith False msg++mk_eqn_newtype :: DerivInstTys -- Information about the arguments to the class+               -> Type         -- The newtype's representation type+               -> DerivM EarlyDerivSpec+mk_eqn_newtype dit rep_ty =+  mk_eqn_from_mechanism $ DerivSpecNewtype { dsm_newtype_dit    = dit+                                           , dsm_newtype_rep_ty = rep_ty }++mk_eqn_via :: [Type] -- All arguments to the class besides the last+           -> Type   -- The last argument to the class+           -> Type   -- The @via@ type+           -> DerivM EarlyDerivSpec+mk_eqn_via cls_tys inst_ty via_ty =+  mk_eqn_from_mechanism $ DerivSpecVia { dsm_via_cls_tys = cls_tys+                                       , dsm_via_inst_ty = inst_ty+                                       , dsm_via_ty      = via_ty }++-- Derive an instance without a user-requested deriving strategy. This uses+-- heuristics to determine which deriving strategy to use.+-- See Note [Deriving strategies].+mk_eqn_no_strategy :: DerivM EarlyDerivSpec+mk_eqn_no_strategy = do+  DerivEnv { denv_cls      = cls+           , denv_inst_tys = cls_args } <- ask+  fam_envs <- lift tcGetFamInstEnvs++  -- First, check if the last argument is an application of a type constructor.+  -- If not, fall back to DeriveAnyClass.+  if |  Just (cls_tys, inst_ty) <- snocView cls_args+     ,  Just dit <- mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty+     -> if |  isNewTyCon (dit_rep_tc dit)+              -- We have a dedicated code path for newtypes (see the+              -- documentation for mkNewTypeEqn as to why this is the case)+           -> mkNewTypeEqn False dit++           |  otherwise+           -> do -- Otherwise, our only other options are stock or anyclass.+                 -- If it is stock, we must confirm that the last argument's+                 -- type constructor is algebraic.+                 -- See Note [DerivEnv and DerivSpecMechanism] in TcDerivUtils+                 whenIsJust (hasStockDeriving cls) $ \_ ->+                   expectNonDataFamTyCon dit+                 mk_eqn_originative dit++     |  otherwise+     -> mk_eqn_anyclass+  where+    -- Use heuristics (checkOriginativeSideConditions) to determine whether+    -- stock or anyclass deriving should be used.+    mk_eqn_originative :: DerivInstTys -> DerivM EarlyDerivSpec+    mk_eqn_originative dit@(DerivInstTys { dit_cls_tys = cls_tys+                                         , dit_tc      = tc+                                         , dit_rep_tc  = rep_tc }) = do+      DerivEnv { denv_cls  = cls+               , denv_ctxt = deriv_ctxt } <- ask+      dflags <- getDynFlags++      -- See Note [Deriving instances for classes themselves]+      let dac_error msg+            | isClassTyCon rep_tc+            = quotes (ppr tc) <+> text "is a type class,"+                              <+> text "and can only have a derived instance"+                              $+$ text "if DeriveAnyClass is enabled"+            | otherwise+            = nonStdErr cls $$ msg++      case checkOriginativeSideConditions dflags deriv_ctxt cls+             cls_tys tc rep_tc of+        NonDerivableClass   msg -> derivingThingFailWith False (dac_error msg)+        StockClassError msg     -> derivingThingFailWith False msg+        CanDeriveStock gen_fn   -> mk_eqn_from_mechanism $+                                   DerivSpecStock { dsm_stock_dit    = dit+                                                  , dsm_stock_gen_fn = gen_fn }+        CanDeriveAnyClass       -> mk_eqn_from_mechanism DerivSpecAnyClass++{-+************************************************************************+*                                                                      *+            Deriving instances for newtypes+*                                                                      *+************************************************************************+-}++-- Derive an instance for a newtype. We put this logic into its own function+-- because+--+-- (a) When no explicit deriving strategy is requested, we have special+--     heuristics for newtypes to determine which deriving strategy should+--     actually be used. See Note [Deriving strategies].+-- (b) We make an effort to give error messages specifically tailored to+--     newtypes.+mkNewTypeEqn :: Bool -- Was this instance derived using an explicit @newtype@+                     -- deriving strategy?+             -> DerivInstTys -> DerivM EarlyDerivSpec+mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys     = cls_tys+                                             , dit_tc          = tycon+                                             , dit_rep_tc      = rep_tycon+                                             , dit_rep_tc_args = rep_tc_args })+-- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...+  = do DerivEnv { denv_cls   = cls+                , denv_ctxt  = deriv_ctxt } <- ask+       dflags <- getDynFlags++       let newtype_deriving  = xopt LangExt.GeneralizedNewtypeDeriving dflags+           deriveAnyClass    = xopt LangExt.DeriveAnyClass             dflags++           bale_out = derivingThingFailWith newtype_deriving++           non_std     = nonStdErr cls+           suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's"+                     <+> text "newtype-deriving extension"++           -- Here is the plan for newtype derivings.  We see+           --        newtype T a1...an = MkT (t ak+1...an)+           --          deriving (.., C s1 .. sm, ...)+           -- where t is a type,+           --       ak+1...an is a suffix of a1..an, and are all tyvars+           --       ak+1...an do not occur free in t, nor in the s1..sm+           --       (C s1 ... sm) is a  *partial applications* of class C+           --                      with the last parameter missing+           --       (T a1 .. ak) matches the kind of C's last argument+           --              (and hence so does t)+           -- The latter kind-check has been done by deriveTyData already,+           -- and tc_args are already trimmed+           --+           -- We generate the instance+           --       instance forall ({a1..ak} u fvs(s1..sm)).+           --                C s1 .. sm t => C s1 .. sm (T a1...ak)+           -- where T a1...ap is the partial application of+           --       the LHS of the correct kind and p >= k+           --+           --      NB: the variables below are:+           --              tc_tvs = [a1, ..., an]+           --              tyvars_to_keep = [a1, ..., ak]+           --              rep_ty = t ak .. an+           --              deriv_tvs = fvs(s1..sm) \ tc_tvs+           --              tys = [s1, ..., sm]+           --              rep_fn' = t+           --+           -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )+           -- We generate the instance+           --      instance Monad (ST s) => Monad (T s) where++           nt_eta_arity = newTyConEtadArity rep_tycon+                   -- For newtype T a b = MkT (S a a b), the TyCon+                   -- machinery already eta-reduces the representation type, so+                   -- we know that+                   --      T a ~ S a a+                   -- That's convenient here, because we may have to apply+                   -- it to fewer than its original complement of arguments++           -- Note [Newtype representation]+           -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+           -- Need newTyConRhs (*not* a recursive representation finder)+           -- to get the representation type. For example+           --      newtype B = MkB Int+           --      newtype A = MkA B deriving( Num )+           -- We want the Num instance of B, *not* the Num instance of Int,+           -- when making the Num instance of A!+           rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args++           -------------------------------------------------------------------+           --  Figuring out whether we can only do this newtype-deriving thing++           -- See Note [Determining whether newtype-deriving is appropriate]+           might_be_newtype_derivable+              =  not (non_coercible_class cls)+              && eta_ok+--            && not (isRecursiveTyCon tycon)      -- Note [Recursive newtypes]++           -- Check that eta reduction is OK+           eta_ok = rep_tc_args `lengthAtLeast` nt_eta_arity+             -- The newtype can be eta-reduced to match the number+             --     of type argument actually supplied+             --        newtype T a b = MkT (S [a] b) deriving( Monad )+             --     Here the 'b' must be the same in the rep type (S [a] b)+             --     And the [a] must not mention 'b'.  That's all handled+             --     by nt_eta_rity.++           cant_derive_err = ppUnless eta_ok  eta_msg+           eta_msg = text "cannot eta-reduce the representation type enough"++       MASSERT( cls_tys `lengthIs` (classArity cls - 1) )+       if newtype_strat+       then+           -- Since the user explicitly asked for GeneralizedNewtypeDeriving,+           -- we don't need to perform all of the checks we normally would,+           -- such as if the class being derived is known to produce ill-roled+           -- coercions (e.g., Traversable), since we can just derive the+           -- instance and let it error if need be.+           -- See Note [Determining whether newtype-deriving is appropriate]+           if eta_ok && newtype_deriving+             then mk_eqn_newtype dit rep_inst_ty+             else bale_out (cant_derive_err $$+                            if newtype_deriving then empty else suggest_gnd)+       else+         if might_be_newtype_derivable+             && ((newtype_deriving && not deriveAnyClass)+                  || std_class_via_coercible cls)+         then mk_eqn_newtype dit rep_inst_ty+         else case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys+                                                 tycon rep_tycon of+               StockClassError msg+                 -- There's a particular corner case where+                 --+                 -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are+                 --    both enabled at the same time+                 -- 2. We're deriving a particular stock derivable class+                 --    (such as Functor)+                 --+                 -- and the previous cases won't catch it. This fixes the bug+                 -- reported in #10598.+                 | might_be_newtype_derivable && newtype_deriving+                -> mk_eqn_newtype dit rep_inst_ty+                 -- Otherwise, throw an error for a stock class+                 | might_be_newtype_derivable && not newtype_deriving+                -> bale_out (msg $$ suggest_gnd)+                 | otherwise+                -> bale_out msg++               -- Must use newtype deriving or DeriveAnyClass+               NonDerivableClass _msg+                 -- Too hard, even with newtype deriving+                 | newtype_deriving           -> bale_out cant_derive_err+                 -- Try newtype deriving!+                 -- Here we suggest GeneralizedNewtypeDeriving even in cases+                 -- where it may not be applicable. See #9600.+                 | otherwise                  -> bale_out (non_std $$ suggest_gnd)++               -- DeriveAnyClass+               CanDeriveAnyClass -> do+                 -- If both DeriveAnyClass and GeneralizedNewtypeDeriving are+                 -- enabled, we take the diplomatic approach of defaulting to+                 -- DeriveAnyClass, but emitting a warning about the choice.+                 -- See Note [Deriving strategies]+                 when (newtype_deriving && deriveAnyClass) $+                   lift $ whenWOptM Opt_WarnDerivingDefaults $+                     addWarnTc (Reason Opt_WarnDerivingDefaults) $ sep+                     [ text "Both DeriveAnyClass and"+                       <+> text "GeneralizedNewtypeDeriving are enabled"+                     , text "Defaulting to the DeriveAnyClass strategy"+                       <+> text "for instantiating" <+> ppr cls+                     , text "Use DerivingStrategies to pick"+                       <+> text "a different strategy"+                      ]+                 mk_eqn_from_mechanism DerivSpecAnyClass+               -- CanDeriveStock+               CanDeriveStock gen_fn -> mk_eqn_from_mechanism $+                                        DerivSpecStock { dsm_stock_dit    = dit+                                                       , dsm_stock_gen_fn = gen_fn }++{-+Note [Recursive newtypes]+~~~~~~~~~~~~~~~~~~~~~~~~~+Newtype deriving works fine, even if the newtype is recursive.+e.g.    newtype S1 = S1 [T1 ()]+        newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )+Remember, too, that type families are currently (conservatively) given+a recursive flag, so this also allows newtype deriving to work+for type famillies.++We used to exclude recursive types, because we had a rather simple+minded way of generating the instance decl:+   newtype A = MkA [A]+   instance Eq [A] => Eq A      -- Makes typechecker loop!+But now we require a simple context, so it's ok.++Note [Determining whether newtype-deriving is appropriate]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we see+  newtype NT = MkNT Foo+    deriving C+we have to decide how to perform the deriving. Do we do newtype deriving,+or do we do normal deriving? In general, we prefer to do newtype deriving+wherever possible. So, we try newtype deriving unless there's a glaring+reason not to.++"Glaring reasons not to" include trying to derive a class for which a+coercion-based instance doesn't make sense. These classes are listed in+the definition of non_coercible_class. They include Show (since it must+show the name of the datatype) and Traversable (since a coercion-based+Traversable instance is ill-roled).++However, non_coercible_class is ignored if the user explicitly requests+to derive an instance with GeneralizedNewtypeDeriving using the newtype+deriving strategy. In such a scenario, GHC will unquestioningly try to+derive the instance via coercions (even if the final generated code is+ill-roled!). See Note [Deriving strategies].++Note that newtype deriving might fail, even after we commit to it. This+is because the derived instance uses `coerce`, which must satisfy its+`Coercible` constraint. This is different than other deriving scenarios,+where we're sure that the resulting instance will type-check.++Note [GND and associated type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's possible to use GeneralizedNewtypeDeriving (GND) to derive instances for+classes with associated type families. A general recipe is:++    class C x y z where+      type T y z x+      op :: x -> [y] -> z++    newtype N a = MkN <rep-type> deriving( C )++    =====>++    instance C x y <rep-type> => C x y (N a) where+      type T y (N a) x = T y <rep-type> x+      op = coerce (op :: x -> [y] -> <rep-type>)++However, we must watch out for three things:++(a) The class must not contain any data families. If it did, we'd have to+    generate a fresh data constructor name for the derived data family+    instance, and it's not clear how to do this.++(b) Each associated type family's type variables must mention the last type+    variable of the class. As an example, you wouldn't be able to use GND to+    derive an instance of this class:++      class C a b where+        type T a++    But you would be able to derive an instance of this class:++      class C a b where+        type T b++    The difference is that in the latter T mentions the last parameter of C+    (i.e., it mentions b), but the former T does not. If you tried, e.g.,++      newtype Foo x = Foo x deriving (C a)++    with the former definition of C, you'd end up with something like this:++      instance C a (Foo x) where+        type T a = T ???++    This T family instance doesn't mention the newtype (or its representation+    type) at all, so we disallow such constructions with GND.++(c) UndecidableInstances might need to be enabled. Here's a case where it is+    most definitely necessary:++      class C a where+        type T a+      newtype Loop = Loop MkLoop deriving C++      =====>++      instance C Loop where+        type T Loop = T Loop++    Obviously, T Loop would send the typechecker into a loop. Unfortunately,+    you might even need UndecidableInstances even in cases where the+    typechecker would be guaranteed to terminate. For example:++      instance C Int where+        type C Int = Int+      newtype MyInt = MyInt Int deriving C++      =====>++      instance C MyInt where+        type T MyInt = T Int++    GHC's termination checker isn't sophisticated enough to conclude that the+    definition of T MyInt terminates, so UndecidableInstances is required.++(d) For the time being, we do not allow the last type variable of the class to+    appear in a /kind/ of an associated type family definition. For instance:++    class C a where+      type T1 a        -- OK+      type T2 (x :: a) -- Illegal: a appears in the kind of x+      type T3 y :: a   -- Illegal: a appears in the kind of (T3 y)++    The reason we disallow this is because our current approach to deriving+    associated type family instances—i.e., by unwrapping the newtype's type+    constructor as shown above—is ill-equipped to handle the scenario when+    the last type variable appears as an implicit argument. In the worst case,+    allowing the last variable to appear in a kind can result in improper Core+    being generated (see #14728).++    There is hope for this feature being added some day, as one could+    conceivably take a newtype axiom (which witnesses a coercion between a+    newtype and its representation type) at lift that through each associated+    type at the Core level. See #14728, comment:3 for a sketch of how this+    might work. Until then, we disallow this featurette wholesale.++The same criteria apply to DerivingVia.++************************************************************************+*                                                                      *+\subsection[TcDeriv-normal-binds]{Bindings for the various classes}+*                                                                      *+************************************************************************++After all the trouble to figure out the required context for the+derived instance declarations, all that's left is to chug along to+produce them.  They will then be shoved into @tcInstDecls2@, which+will do all its usual business.++There are lots of possibilities for code to generate.  Here are+various general remarks.++PRINCIPLES:+\begin{itemize}+\item+We want derived instances of @Eq@ and @Ord@ (both v common) to be+``you-couldn't-do-better-by-hand'' efficient.++\item+Deriving @Show@---also pretty common--- should also be reasonable good code.++\item+Deriving for the other classes isn't that common or that big a deal.+\end{itemize}++PRAGMATICS:++\begin{itemize}+\item+Deriving @Ord@ is done mostly with the 1.3 @compare@ method.++\item+Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.++\item+We {\em normally} generate code only for the non-defaulted methods;+there are some exceptions for @Eq@ and (especially) @Ord@...++\item+Sometimes we use a @_con2tag_<tycon>@ function, which returns a data+constructor's numeric (@Int#@) tag.  These are generated by+@gen_tag_n_con_binds@, and the heuristic for deciding if one of+these is around is given by @hasCon2TagFun@.++The examples under the different sections below will make this+clearer.++\item+Much less often (really just for deriving @Ix@), we use a+@_tag2con_<tycon>@ function.  See the examples.++\item+We use the renamer!!!  Reason: we're supposed to be+producing @LHsBinds Name@ for the methods, but that means+producing correctly-uniquified code on the fly.  This is entirely+possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.+So, instead, we produce @MonoBinds RdrName@ then heave 'em through+the renamer.  What a great hack!+\end{itemize}+-}++-- Generate the InstInfo for the required instance+-- plus any auxiliary bindings required+genInst :: DerivSpec theta+        -> TcM (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])+-- We must use continuation-returning style here to get the order in which we+-- typecheck family instances and derived instances right.+-- See Note [Staging of tcDeriving]+genInst spec@(DS { ds_tvs = tvs, ds_mechanism = mechanism+                 , ds_tys = tys, ds_cls = clas, ds_loc = loc+                 , ds_standalone_wildcard = wildcard })+  = do (meth_binds, deriv_stuff, unusedNames)+         <- set_span_and_ctxt $+            genDerivStuff mechanism loc clas tys tvs+       let mk_inst_info theta = set_span_and_ctxt $ do+             inst_spec <- newDerivClsInst theta spec+             doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism+             traceTc "newder" (ppr inst_spec)+             return $ InstInfo+                       { iSpec   = inst_spec+                       , iBinds  = InstBindings+                                     { ib_binds = meth_binds+                                     , ib_tyvars = map Var.varName tvs+                                     , ib_pragmas = []+                                     , ib_extensions = extensions+                                     , ib_derived = True } }+       return (mk_inst_info, deriv_stuff, unusedNames)+  where+    extensions :: [LangExt.Extension]+    extensions+      | isDerivSpecNewtype mechanism || isDerivSpecVia mechanism+        -- Both these flags are needed for higher-rank uses of coerce+        -- See Note [Newtype-deriving instances] in TcGenDeriv+      = [LangExt.ImpredicativeTypes, LangExt.RankNTypes]+      | otherwise+      = []++    set_span_and_ctxt :: TcM a -> TcM a+    set_span_and_ctxt = setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys)++-- Checks:+--+-- * All of the data constructors for a data type are in scope for a+--   standalone-derived instance (for `stock` and `newtype` deriving).+--+-- * All of the associated type families of a class are suitable for+--   GeneralizedNewtypeDeriving or DerivingVia (for `newtype` and `via`+--   deriving).+doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM ()+doDerivInstErrorChecks1 mechanism =+  case mechanism of+    DerivSpecStock{dsm_stock_dit = dit}+      -> data_cons_in_scope_check dit+    DerivSpecNewtype{dsm_newtype_dit = dit}+      -> do atf_coerce_based_error_checks+            data_cons_in_scope_check dit+    DerivSpecAnyClass{}+      -> pure ()+    DerivSpecVia{}+      -> atf_coerce_based_error_checks+  where+    -- When processing a standalone deriving declaration, check that all of the+    -- constructors for the data type are in scope. For instance:+    --+    --   import M (T)+    --   deriving stock instance Eq T+    --+    -- This should be rejected, as the derived Eq instance would need to refer+    -- to the constructors for T, which are not in scope.+    --+    -- Note that the only strategies that require this check are `stock` and+    -- `newtype`. Neither `anyclass` nor `via` require it as the code that they+    -- generate does not require using data constructors.+    data_cons_in_scope_check :: DerivInstTys -> DerivM ()+    data_cons_in_scope_check (DerivInstTys { dit_tc     = tc+                                           , dit_rep_tc = rep_tc }) = do+      standalone <- isStandaloneDeriv+      when standalone $ do+        let bale_out msg = do err <- derivingThingErrMechanism mechanism msg+                              lift $ failWithTc err++        rdr_env <- lift getGlobalRdrEnv+        let data_con_names = map dataConName (tyConDataCons rep_tc)+            hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&+                               (isAbstractTyCon rep_tc ||+                                any not_in_scope data_con_names)+            not_in_scope dc  = isNothing (lookupGRE_Name rdr_env dc)++        -- Make sure to also mark the data constructors as used so that GHC won't+        -- mistakenly emit -Wunused-imports warnings about them.+        lift $ addUsedDataCons rdr_env rep_tc++        unless (not hidden_data_cons) $+          bale_out $ derivingHiddenErr tc++    -- Ensure that a class's associated type variables are suitable for+    -- GeneralizedNewtypeDeriving or DerivingVia. Unsurprisingly, this check is+    -- only required for the `newtype` and `via` strategies.+    --+    -- See Note [GND and associated type families]+    atf_coerce_based_error_checks :: DerivM ()+    atf_coerce_based_error_checks = do+      cls <- asks denv_cls+      let bale_out msg = do err <- derivingThingErrMechanism mechanism msg+                            lift $ failWithTc err++          cls_tyvars = classTyVars cls++          ats_look_sensible+             =  -- Check (a) from Note [GND and associated type families]+                no_adfs+                -- Check (b) from Note [GND and associated type families]+             && isNothing at_without_last_cls_tv+                -- Check (d) from Note [GND and associated type families]+             && isNothing at_last_cls_tv_in_kinds++          (adf_tcs, atf_tcs) = partition isDataFamilyTyCon at_tcs+          no_adfs            = null adf_tcs+                 -- We cannot newtype-derive data family instances++          at_without_last_cls_tv+            = find (\tc -> last_cls_tv `notElem` tyConTyVars tc) atf_tcs+          at_last_cls_tv_in_kinds+            = find (\tc -> any (at_last_cls_tv_in_kind . tyVarKind)+                               (tyConTyVars tc)+                        || at_last_cls_tv_in_kind (tyConResKind tc)) atf_tcs+          at_last_cls_tv_in_kind kind+            = last_cls_tv `elemVarSet` exactTyCoVarsOfType kind+          at_tcs = classATs cls+          last_cls_tv = ASSERT( notNull cls_tyvars )+                        last cls_tyvars++          cant_derive_err+             = vcat [ ppUnless no_adfs adfs_msg+                    , maybe empty at_without_last_cls_tv_msg+                            at_without_last_cls_tv+                    , maybe empty at_last_cls_tv_in_kinds_msg+                            at_last_cls_tv_in_kinds+                    ]+          adfs_msg  = text "the class has associated data types"+          at_without_last_cls_tv_msg at_tc = hang+            (text "the associated type" <+> quotes (ppr at_tc)+             <+> text "is not parameterized over the last type variable")+            2 (text "of the class" <+> quotes (ppr cls))+          at_last_cls_tv_in_kinds_msg at_tc = hang+            (text "the associated type" <+> quotes (ppr at_tc)+             <+> text "contains the last type variable")+           2 (text "of the class" <+> quotes (ppr cls)+             <+> text "in a kind, which is not (yet) allowed")+      unless ats_look_sensible $ bale_out cant_derive_err++doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan+                        -> DerivSpecMechanism -> TcM ()+doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism+  = do { traceTc "doDerivInstErrorChecks2" (ppr clas_inst)+       ; dflags <- getDynFlags+       ; xpartial_sigs <- xoptM LangExt.PartialTypeSignatures+       ; wpartial_sigs <- woptM Opt_WarnPartialTypeSignatures++         -- Error if PartialTypeSignatures isn't enabled when a user tries+         -- to write @deriving instance _ => Eq (Foo a)@. Or, if that+         -- extension is enabled, give a warning if -Wpartial-type-signatures+         -- is enabled.+       ; case wildcard of+           Nothing -> pure ()+           Just span -> setSrcSpan span $ do+             checkTc xpartial_sigs (hang partial_sig_msg 2 pts_suggestion)+             warnTc (Reason Opt_WarnPartialTypeSignatures)+                    wpartial_sigs partial_sig_msg++         -- Check for Generic instances that are derived with an exotic+         -- deriving strategy like DAC+         -- See Note [Deriving strategies]+       ; when (exotic_mechanism && className clas `elem` genericClassNames) $+         do { failIfTc (safeLanguageOn dflags) gen_inst_err+            ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } }+  where+    exotic_mechanism = not $ isDerivSpecStock mechanism++    partial_sig_msg = text "Found type wildcard" <+> quotes (char '_')+                  <+> text "standing for" <+> quotes (pprTheta theta)++    pts_suggestion+      = text "To use the inferred type, enable PartialTypeSignatures"++    gen_inst_err = text "Generic instances can only be derived in"+               <+> text "Safe Haskell using the stock strategy."++derivingThingFailWith :: Bool -- If True, add a snippet about how not even+                              -- GeneralizedNewtypeDeriving would make this+                              -- declaration work. This only kicks in when+                              -- an explicit deriving strategy is not given.+                      -> SDoc -- The error message+                      -> DerivM a+derivingThingFailWith newtype_deriving msg = do+  err <- derivingThingErrM newtype_deriving msg+  lift $ failWithTc err++genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class+              -> [Type] -> [TyVar]+              -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])+genDerivStuff mechanism loc clas inst_tys tyvars+  = case mechanism of+      -- See Note [Bindings for Generalised Newtype Deriving]+      DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty}+        -> gen_newtype_or_via rhs_ty++      -- Try a stock deriver+      DerivSpecStock { dsm_stock_dit    = DerivInstTys{dit_rep_tc = rep_tc}+                     , dsm_stock_gen_fn = gen_fn }+        -> gen_fn loc rep_tc inst_tys++      -- Try DeriveAnyClass+      DerivSpecAnyClass -> do+        let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)+            mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env+        dflags <- getDynFlags+        tyfam_insts <-+          -- canDeriveAnyClass should ensure that this code can't be reached+          -- unless -XDeriveAnyClass is enabled.+          ASSERT2( isValid (canDeriveAnyClass dflags)+                 , ppr "genDerivStuff: bad derived class" <+> ppr clas )+          mapM (tcATDefault loc mini_subst emptyNameSet)+               (classATItems clas)+        return ( emptyBag -- No method bindings are needed...+               , listToBag (map DerivFamInst (concat tyfam_insts))+               -- ...but we may need to generate binding for associated type+               -- family default instances.+               -- See Note [DeriveAnyClass and default family instances]+               , [] )++      -- Try DerivingVia+      DerivSpecVia{dsm_via_ty = via_ty}+        -> gen_newtype_or_via via_ty+  where+    gen_newtype_or_via ty = do+      (binds, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty+      return (binds, faminsts, [])++{-+Note [Bindings for Generalised Newtype Deriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  class Eq a => C a where+     f :: a -> a+  newtype N a = MkN [a] deriving( C )+  instance Eq (N a) where ...++The 'deriving C' clause generates, in effect+  instance (C [a], Eq a) => C (N a) where+     f = coerce (f :: [a] -> [a])++This generates a cast for each method, but allows the superclasse to+be worked out in the usual way.  In this case the superclass (Eq (N+a)) will be solved by the explicit Eq (N a) instance.  We do *not*+create the superclasses by casting the superclass dictionaries for the+representation type.++See the paper "Safe zero-cost coercions for Haskell".++Note [DeriveAnyClass and default family instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When a class has a associated type family with a default instance, e.g.:++  class C a where+    type T a+    type T a = Char++then there are a couple of scenarios in which a user would expect T a to+default to Char. One is when an instance declaration for C is given without+an implementation for T:++  instance C Int++Another scenario in which this can occur is when the -XDeriveAnyClass extension+is used:++  data Example = Example deriving (C, Generic)++In the latter case, we must take care to check if C has any associated type+families with default instances, because -XDeriveAnyClass will never provide+an implementation for them. We "fill in" the default instances using the+tcATDefault function from TcClassDcl (which is also used in TcInstDcls to+handle the empty instance declaration case).++Note [Deriving strategies]+~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC has a notion of deriving strategies, which allow the user to explicitly+request which approach to use when deriving an instance (enabled with the+-XDerivingStrategies language extension). For more information, refer to the+original issue (#10598) or the associated wiki page:+https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies++A deriving strategy can be specified in a deriving clause:++    newtype Foo = MkFoo Bar+      deriving newtype C++Or in a standalone deriving declaration:++    deriving anyclass instance C Foo++-XDerivingStrategies also allows the use of multiple deriving clauses per data+declaration so that a user can derive some instance with one deriving strategy+and other instances with another deriving strategy. For example:++    newtype Baz = Baz Quux+      deriving          (Eq, Ord)+      deriving stock    (Read, Show)+      deriving newtype  (Num, Floating)+      deriving anyclass C++Currently, the deriving strategies are:++* stock: Have GHC implement a "standard" instance for a data type, if possible+  (e.g., Eq, Ord, Generic, Data, Functor, etc.)++* anyclass: Use -XDeriveAnyClass++* newtype: Use -XGeneralizedNewtypeDeriving++* via: Use -XDerivingVia++The latter two strategies (newtype and via) are referred to as the+"coerce-based" strategies, since they generate code that relies on the `coerce`+function. See, for instance, TcDerivInfer.inferConstraintsCoerceBased.++The former two strategies (stock and anyclass), in contrast, are+referred to as the "originative" strategies, since they create "original"+instances instead of "reusing" old instances (by way of `coerce`).+See, for instance, TcDerivUtils.checkOriginativeSideConditions.++If an explicit deriving strategy is not given, GHC has an algorithm it uses to+determine which strategy it will actually use. The algorithm is quite long,+so it lives in the Haskell wiki at+https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies+("The deriving strategy resolution algorithm" section).++Internally, GHC uses the DerivStrategy datatype to denote a user-requested+deriving strategy, and it uses the DerivSpecMechanism datatype to denote what+GHC will use to derive the instance after taking the above steps. In other+words, GHC will always settle on a DerivSpecMechnism, even if the user did not+ask for a particular DerivStrategy (using the algorithm linked to above).++Note [Deriving instances for classes themselves]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Much of the code in TcDeriv assumes that deriving only works on data types.+But this assumption doesn't hold true for DeriveAnyClass, since it's perfectly+reasonable to do something like this:++  {-# LANGUAGE DeriveAnyClass #-}+  class C1 (a :: Constraint) where+  class C2 where+  deriving instance C1 C2+    -- This is equivalent to `instance C1 C2`++If DeriveAnyClass isn't enabled in the code above (i.e., it defaults to stock+deriving), we throw a special error message indicating that DeriveAnyClass is+the only way to go. We don't bother throwing this error if an explicit 'stock'+or 'newtype' keyword is used, since both options have their own perfectly+sensible error messages in the case of the above code (as C1 isn't a stock+derivable class, and C2 isn't a newtype).++************************************************************************+*                                                                      *+\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}+*                                                                      *+************************************************************************+-}++nonUnaryErr :: LHsSigType GhcRn -> SDoc+nonUnaryErr ct = quotes (ppr ct)+  <+> text "is not a unary constraint, as expected by a deriving clause"++nonStdErr :: Class -> SDoc+nonStdErr cls =+      quotes (ppr cls)+  <+> text "is not a stock derivable class (Eq, Show, etc.)"++gndNonNewtypeErr :: SDoc+gndNonNewtypeErr =+  text "GeneralizedNewtypeDeriving cannot be used on non-newtypes"++derivingNullaryErr :: MsgDoc+derivingNullaryErr = text "Cannot derive instances for nullary classes"++derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> MsgDoc+derivingKindErr tc cls cls_tys cls_kind enough_args+  = sep [ hang (text "Cannot derive well-kinded instance of form"+                      <+> quotes (pprClassPred cls cls_tys+                                    <+> parens (ppr tc <+> text "...")))+               2 gen1_suggestion+        , nest 2 (text "Class" <+> quotes (ppr cls)+                      <+> text "expects an argument of kind"+                      <+> quotes (pprKind cls_kind))+        ]+  where+    gen1_suggestion | cls `hasKey` gen1ClassKey && enough_args+                    = text "(Perhaps you intended to use PolyKinds)"+                    | otherwise = Outputable.empty++derivingViaKindErr :: Class -> Kind -> Type -> Kind -> MsgDoc+derivingViaKindErr cls cls_kind via_ty via_kind+  = hang (text "Cannot derive instance via" <+> quotes (pprType via_ty))+       2 (text "Class" <+> quotes (ppr cls)+               <+> text "expects an argument of kind"+               <+> quotes (pprKind cls_kind) <> char ','+      $+$ text "but" <+> quotes (pprType via_ty)+               <+> text "has kind" <+> quotes (pprKind via_kind))++derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc+derivingEtaErr cls cls_tys inst_ty+  = sep [text "Cannot eta-reduce to an instance of form",+         nest 2 (text "instance (...) =>"+                <+> pprClassPred cls (cls_tys ++ [inst_ty]))]++derivingThingErr :: Bool -> Class -> [Type]+                 -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc+derivingThingErr newtype_deriving cls cls_args mb_strat why+  = derivingThingErr' newtype_deriving cls cls_args mb_strat+                      (maybe empty derivStrategyName mb_strat) why++derivingThingErrM :: Bool -> MsgDoc -> DerivM MsgDoc+derivingThingErrM newtype_deriving why+  = do DerivEnv { denv_cls      = cls+                , denv_inst_tys = cls_args+                , denv_strat    = mb_strat } <- ask+       pure $ derivingThingErr newtype_deriving cls cls_args mb_strat why++derivingThingErrMechanism :: DerivSpecMechanism -> MsgDoc -> DerivM MsgDoc+derivingThingErrMechanism mechanism why+  = do DerivEnv { denv_cls      = cls+                , denv_inst_tys = cls_args+                , denv_strat    = mb_strat } <- ask+       pure $ derivingThingErr' (isDerivSpecNewtype mechanism) cls cls_args mb_strat+                (derivStrategyName $ derivSpecMechanismToStrategy mechanism) why++derivingThingErr' :: Bool -> Class -> [Type]+                  -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc -> MsgDoc+derivingThingErr' newtype_deriving cls cls_args mb_strat strat_msg why+  = sep [(hang (text "Can't make a derived instance of")+             2 (quotes (ppr pred) <+> via_mechanism)+          $$ nest 2 extra) <> colon,+         nest 2 why]+  where+    strat_used = isJust mb_strat+    extra | not strat_used, newtype_deriving+          = text "(even with cunning GeneralizedNewtypeDeriving)"+          | otherwise = empty+    pred = mkClassPred cls cls_args     via_mechanism | strat_used                   = text "with the" <+> strat_msg <+> text "strategy"                   | otherwise
compiler/typecheck/TcDerivInfer.hs view
@@ -11,7 +11,7 @@  module TcDerivInfer (inferConstraints, simplifyInstanceContexts) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -22,19 +22,26 @@ import ErrUtils import Inst import Outputable+import Pair import PrelNames import TcDerivUtils import TcEnv+import TcGenDeriv import TcGenFunctor import TcGenGenerics import TcMType import TcRnMonad+import TcOrigin+import Constraint+import Predicate import TcType import TyCon+import TyCoPpr (pprTyVars) import Type import TcSimplify import TcValidity (validDerivPred) import TcUnify (buildImplicationFor, checkConstraints)+import TysWiredIn (typeToTypeKind) import Unify (tcUnifyTy) import Util import Var@@ -43,7 +50,7 @@ import Control.Monad import Control.Monad.Trans.Class  (lift) import Control.Monad.Trans.Reader (ask)-import Data.List+import Data.List                  (sortBy) import Data.Maybe  ----------------------@@ -66,18 +73,38 @@ -- generated method definitions should succeed.   This set will be simplified -- before being used in the instance declaration inferConstraints mechanism-  = do { DerivEnv { denv_tc          = tc-                  , denv_tc_args     = tc_args-                  , denv_cls         = main_cls-                  , denv_cls_tys     = cls_tys } <- ask+  = do { DerivEnv { denv_tvs      = tvs+                  , denv_cls      = main_cls+                  , denv_inst_tys = inst_tys } <- ask        ; wildcard <- isStandaloneWildcardDeriv-       ; let is_anyclass = isDerivSpecAnyClass mechanism-             infer_constraints-               | is_anyclass = inferConstraintsDAC inst_tys-               | otherwise   = inferConstraintsDataConArgs inst_ty inst_tys+       ; let infer_constraints :: DerivM ([ThetaOrigin], [TyVar], [TcType])+             infer_constraints =+               case mechanism of+                 DerivSpecStock{dsm_stock_dit = dit}+                   -> inferConstraintsStock dit+                 DerivSpecAnyClass+                   -> infer_constraints_simple inferConstraintsAnyclass+                 DerivSpecNewtype { dsm_newtype_dit =+                                      DerivInstTys{dit_cls_tys = cls_tys}+                                  , dsm_newtype_rep_ty = rep_ty }+                   -> infer_constraints_simple $+                      inferConstraintsCoerceBased cls_tys rep_ty+                 DerivSpecVia { dsm_via_cls_tys = cls_tys+                              , dsm_via_ty = via_ty }+                   -> infer_constraints_simple $+                      inferConstraintsCoerceBased cls_tys via_ty -             inst_ty  = mkTyConApp tc tc_args-             inst_tys = cls_tys ++ [inst_ty]+             -- Most deriving strategies do not need to do anything special to+             -- the type variables and arguments to the class in the derived+             -- instance, so they can pass through unchanged. The exception to+             -- this rule is stock deriving. See+             -- Note [Inferring the instance context].+             infer_constraints_simple+               :: DerivM [ThetaOrigin]+               -> DerivM ([ThetaOrigin], [TyVar], [TcType])+             infer_constraints_simple infer_thetas = do+               thetas <- infer_thetas+               pure (thetas, tvs, inst_tys)               -- Constraints arising from superclasses              -- See Note [Superclasses of derived instance]@@ -98,20 +125,43 @@        ; return ( sc_constraints ++ inferred_constraints                 , tvs', inst_tys' ) } --- | Like 'inferConstraints', but used only in the case of deriving strategies--- where the constraints are inferred by inspecting the fields of each data--- constructor (i.e., stock- and newtype-deriving).-inferConstraintsDataConArgs :: TcType -> [TcType]-                            -> DerivM ([ThetaOrigin], [TyVar], [TcType])-inferConstraintsDataConArgs inst_ty inst_tys-  = do DerivEnv { denv_tvs         = tvs-                , denv_rep_tc      = rep_tc-                , denv_rep_tc_args = rep_tc_args-                , denv_cls         = main_cls-                , denv_cls_tys     = cls_tys } <- ask+-- | Like 'inferConstraints', but used only in the case of the @stock@ deriving+-- strategy. The constraints are inferred by inspecting the fields of each data+-- constructor. In this example:+--+-- > data Foo = MkFoo Int Char deriving Show+--+-- We would infer the following constraints ('ThetaOrigin's):+--+-- > (Show Int, Show Char)+--+-- Note that this function also returns the type variables ('TyVar's) and+-- class arguments ('TcType's) for the resulting instance. This is because+-- when deriving 'Functor'-like classes, we must sometimes perform kind+-- substitutions to ensure the resulting instance is well kinded, which may+-- affect the type variables and class arguments. In this example:+--+-- > newtype Compose (f :: k -> Type) (g :: Type -> k) (a :: Type) =+-- >   Compose (f (g a)) deriving stock Functor+--+-- We must unify @k@ with @Type@ in order for the resulting 'Functor' instance+-- to be well kinded, so we return @[]@/@[Type, f, g]@ for the+-- 'TyVar's/'TcType's, /not/ @[k]@/@[k, f, g]@.+-- See Note [Inferring the instance context].+inferConstraintsStock :: DerivInstTys+                      -> DerivM ([ThetaOrigin], [TyVar], [TcType])+inferConstraintsStock (DerivInstTys { dit_cls_tys     = cls_tys+                                    , dit_tc          = tc+                                    , dit_tc_args     = tc_args+                                    , dit_rep_tc      = rep_tc+                                    , dit_rep_tc_args = rep_tc_args })+  = do DerivEnv { denv_tvs      = tvs+                , denv_cls      = main_cls+                , denv_inst_tys = inst_tys } <- ask        wildcard <- isStandaloneWildcardDeriv -       let tc_binders = tyConBinders rep_tc+       let inst_ty    = mkTyConApp tc tc_args+           tc_binders = tyConBinders rep_tc            choose_level bndr              | isNamedTyConBinder bndr = KindLevel              | otherwise               = TypeLevel@@ -272,7 +322,7 @@                        $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args )                 do { let (arg_constraints, tvs', inst_tys')                            = con_arg_constraints get_std_constrained_tys-                   ; lift $ traceTc "inferConstraintsDataConArgs" $ vcat+                   ; lift $ traceTc "inferConstraintsStock" $ vcat                           [ ppr main_cls <+> ppr inst_tys'                           , ppr arg_constraints                           ]@@ -280,9 +330,6 @@                                                  ++ arg_constraints                             , tvs', inst_tys') } -typeToTypeKind :: Kind-typeToTypeKind = liftedTypeKind `mkFunTy` liftedTypeKind- -- | Like 'inferConstraints', but used only in the case of @DeriveAnyClass@, -- which gathers its constraints based on the type signatures of the class's -- methods instead of the types of the data constructor's field.@@ -290,10 +337,10 @@ -- See Note [Gathering and simplifying constraints for DeriveAnyClass] -- for an explanation of how these constraints are used to determine the -- derived instance context.-inferConstraintsDAC :: [TcType] -> DerivM ([ThetaOrigin], [TyVar], [TcType])-inferConstraintsDAC inst_tys-  = do { DerivEnv { denv_tvs = tvs-                  , denv_cls = cls } <- ask+inferConstraintsAnyclass :: DerivM [ThetaOrigin]+inferConstraintsAnyclass+  = do { DerivEnv { denv_cls      = cls+                  , denv_inst_tys = inst_tys } <- ask        ; wildcard <- isStandaloneWildcardDeriv         ; let gen_dms = [ (sel_id, dm_ty)@@ -320,8 +367,59 @@                                 meth_tvs dm_tvs meth_theta (tau_eq:dm_theta)) }         ; theta_origins <- lift $ mapM do_one_meth gen_dms-       ; return (theta_origins, tvs, inst_tys) }+       ; return theta_origins } +-- Like 'inferConstraints', but used only for @GeneralizedNewtypeDeriving@ and+-- @DerivingVia@. Since both strategies generate code involving 'coerce', the+-- inferred constraints set up the scaffolding needed to typecheck those uses+-- of 'coerce'. In this example:+--+-- > newtype Age = MkAge Int deriving newtype Num+--+-- We would infer the following constraints ('ThetaOrigin's):+--+-- > (Num Int, Coercible Age Int)+inferConstraintsCoerceBased :: [Type] -> Type+                            -> DerivM [ThetaOrigin]+inferConstraintsCoerceBased cls_tys rep_ty = do+  DerivEnv { denv_tvs      = tvs+           , denv_cls      = cls+           , denv_inst_tys = inst_tys } <- ask+  sa_wildcard <- isStandaloneWildcardDeriv+  let -- The following functions are polymorphic over the representation+      -- type, since we might either give it the underlying type of a+      -- newtype (for GeneralizedNewtypeDeriving) or a @via@ type+      -- (for DerivingVia).+      rep_tys ty  = cls_tys ++ [ty]+      rep_pred ty = mkClassPred cls (rep_tys ty)+      rep_pred_o ty = mkPredOrigin deriv_origin TypeLevel (rep_pred ty)+              -- rep_pred is the representation dictionary, from where+              -- we are going to get all the methods for the final+              -- dictionary+      deriv_origin = mkDerivOrigin sa_wildcard++      -- Next we collect constraints for the class methods+      -- If there are no methods, we don't need any constraints+      -- Otherwise we need (C rep_ty), for the representation methods,+      -- and constraints to coerce each individual method+      meth_preds :: Type -> [PredOrigin]+      meth_preds ty+        | null meths = [] -- No methods => no constraints+                          -- (#12814)+        | otherwise = rep_pred_o ty : coercible_constraints ty+      meths = classMethods cls+      coercible_constraints ty+        = [ mkPredOrigin (DerivOriginCoerce meth t1 t2 sa_wildcard)+                         TypeLevel (mkReprPrimEqPred t1 t2)+          | meth <- meths+          , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs+                                       inst_tys ty meth ]++      all_thetas :: Type -> [ThetaOrigin]+      all_thetas ty = [mkThetaOriginFromPreds $ meth_preds ty]++  pure (all_thetas rep_ty)+ {- Note [Inferring the instance context] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There are two sorts of 'deriving', as represented by the two constructors@@ -346,7 +444,7 @@     the instance context (theta) is user-supplied  For the InferContext case, we must figure out the-instance context (inferConstraintsDataConArgs). Suppose we are inferring+instance context (inferConstraintsStock). Suppose we are inferring the instance context for     C t1 .. tn (T s1 .. sm) There are two cases@@ -365,7 +463,7 @@  In the functor-like case, we may need to unify some kind variables with * in order for the generated instance to be well-kinded. An example from-Trac #10524:+#10524:    newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1)     = Compose (f (g a)) deriving Functor@@ -456,7 +554,7 @@         Eq (T a b) = (Ping a, Pong b, ...)  Now we can get a (recursive) equation from the data decl.  This part-is done by inferConstraintsDataConArgs.+is done by inferConstraintsStock.          Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1                    u Eq (T b a) u Eq Int        -- From C2@@ -848,7 +946,7 @@ Note that it is vital that we instantiate the `c` in $gdm_bar's type with a new unification variable for each iteration of simplifyDeriv. If we re-use the same unification variable across multiple iterations, then bad things can happen,-such as Trac #14933.+such as #14933.  Similarly for 'baz', givng the constraint C2
compiler/typecheck/TcDerivUtils.hs view
@@ -10,7 +10,7 @@  module TcDerivUtils (         DerivM, DerivEnv(..),-        DerivSpec(..), pprDerivSpec,+        DerivSpec(..), pprDerivSpec, DerivInstTys(..),         DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock,         isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia,         DerivContext(..), OriginativeDerivStatus(..),@@ -32,7 +32,7 @@ import DynFlags import ErrUtils import HscTypes (lookupFixity, mi_fix)-import HsSyn+import GHC.Hs import Inst import InstEnv import LoadIface (loadInterfaceForName)@@ -44,10 +44,12 @@ import TcGenDeriv import TcGenFunctor import TcGenGenerics+import TcOrigin import TcRnMonad import TcType import THNames (liftClassKey) import TyCon+import TyCoPpr (pprSourceTyCon) import Type import Util import VarSet@@ -89,6 +91,7 @@  -- | Contains all of the information known about a derived instance when -- determining what its @EarlyDerivSpec@ should be.+-- See @Note [DerivEnv and DerivSpecMechanism]@. data DerivEnv = DerivEnv   { denv_overlap_mode :: Maybe OverlapMode     -- ^ Is this an overlapping instance?@@ -96,19 +99,8 @@     -- ^ Universally quantified type variables in the instance   , denv_cls          :: Class     -- ^ Class for which we need to derive an instance-  , denv_cls_tys      :: [Type]-    -- ^ Other arguments to the class except the last-  , denv_tc           :: TyCon-    -- ^ Type constructor for which the instance is requested-    --   (last arguments to the type class)-  , denv_tc_args      :: [Type]-    -- ^ Arguments to the type constructor-  , denv_rep_tc       :: TyCon-    -- ^ The representation tycon for 'denv_tc'-    --   (for data family instances)-  , denv_rep_tc_args  :: [Type]-    -- ^ The representation types for 'denv_tc_args'-    --   (for data family instances)+  , denv_inst_tys     :: [Type]+    -- ^ All arguments to to 'denv_cls' in the derived instance.   , denv_ctxt         :: DerivContext     -- ^ @'SupplyContext' theta@ for standalone deriving (where @theta@ is the     --   context of the instance).@@ -124,22 +116,14 @@   ppr (DerivEnv { denv_overlap_mode = overlap_mode                 , denv_tvs          = tvs                 , denv_cls          = cls-                , denv_cls_tys      = cls_tys-                , denv_tc           = tc-                , denv_tc_args      = tc_args-                , denv_rep_tc       = rep_tc-                , denv_rep_tc_args  = rep_tc_args+                , denv_inst_tys     = inst_tys                 , denv_ctxt         = ctxt                 , denv_strat        = mb_strat })     = hang (text "DerivEnv")          2 (vcat [ text "denv_overlap_mode" <+> ppr overlap_mode                  , text "denv_tvs"          <+> ppr tvs                  , text "denv_cls"          <+> ppr cls-                 , text "denv_cls_tys"      <+> ppr cls_tys-                 , text "denv_tc"           <+> ppr tc-                 , text "denv_tc_args"      <+> ppr tc_args-                 , text "denv_rep_tc"       <+> ppr rep_tc-                 , text "denv_rep_tc_args"  <+> ppr rep_tc_args+                 , text "denv_inst_tys"     <+> ppr inst_tys                  , text "denv_ctxt"         <+> ppr ctxt                  , text "denv_strat"        <+> ppr mb_strat ]) @@ -149,7 +133,6 @@                           , ds_theta               :: theta                           , ds_cls                 :: Class                           , ds_tys                 :: [Type]-                          , ds_tc                  :: TyCon                           , ds_overlap             :: Maybe OverlapMode                           , ds_standalone_wildcard :: Maybe SrcSpan                               -- See Note [Inferring the instance context]@@ -159,10 +142,6 @@         --       df :: forall tvs. theta => C tys         -- The Name is the name for the DFun we'll build         -- The tyvars bind all the variables in the theta-        -- For type families, the tycon in-        --       in ds_tys is the *family* tycon-        --       in ds_tc is the *representation* type-        -- For non-family tycons, both are the same          -- the theta is either the given and final theta, in standalone deriving,         -- or the not-yet-simplified list of constraints together with their origin@@ -179,7 +158,7 @@      axiom :RTList a = Tree a       DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]-        , ds_tc = :RTList, ds_mechanism = DerivSpecNewtype (Tree a) }+        , ds_mechanism = DerivSpecNewtype (Tree a) } -}  pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc@@ -199,41 +178,95 @@ instance Outputable theta => Outputable (DerivSpec theta) where   ppr = pprDerivSpec --- What action to take in order to derive a class instance.--- See Note [Deriving strategies] in TcDeriv+-- | Information about the arguments to the class in a stock- or+-- newtype-derived instance.+-- See @Note [DerivEnv and DerivSpecMechanism]@.+data DerivInstTys = DerivInstTys+  { dit_cls_tys     :: [Type]+    -- ^ Other arguments to the class except the last+  , dit_tc          :: TyCon+    -- ^ Type constructor for which the instance is requested+    --   (last arguments to the type class)+  , dit_tc_args     :: [Type]+    -- ^ Arguments to the type constructor+  , dit_rep_tc      :: TyCon+    -- ^ The representation tycon for 'dit_tc'+    --   (for data family instances). Otherwise the same as 'dit_tc'.+  , dit_rep_tc_args :: [Type]+    -- ^ The representation types for 'dit_tc_args'+    --   (for data family instances). Otherwise the same as 'dit_tc_args'.+  }++instance Outputable DerivInstTys where+  ppr (DerivInstTys { dit_cls_tys = cls_tys, dit_tc = tc, dit_tc_args = tc_args+                    , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args })+    = hang (text "DITTyConHead")+         2 (vcat [ text "dit_cls_tys"     <+> ppr cls_tys+                 , text "dit_tc"          <+> ppr tc+                 , text "dit_tc_args"     <+> ppr tc_args+                 , text "dit_rep_tc"      <+> ppr rep_tc+                 , text "dit_rep_tc_args" <+> ppr rep_tc_args ])++-- | What action to take in order to derive a class instance.+-- See @Note [DerivEnv and DerivSpecMechanism]@, as well as+-- @Note [Deriving strategies]@ in "TcDeriv". data DerivSpecMechanism-  = DerivSpecStock   -- "Standard" classes-      (SrcSpan -> TyCon-               -> [Type]-               -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))-      -- This function returns three things:+    -- | \"Standard\" classes+  = DerivSpecStock+    { dsm_stock_dit    :: DerivInstTys+      -- ^ Information about the arguments to the class in the derived+      -- instance, including what type constructor the last argument is+      -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@.+    , dsm_stock_gen_fn ::+        SrcSpan -> TyCon+                -> [Type]+                -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])+      -- ^ This function returns three things:       --       -- 1. @LHsBinds GhcPs@: The derived instance's function bindings       --    (e.g., @compare (T x) (T y) = compare x y@)+      --       -- 2. @BagDerivStuff@: Auxiliary bindings needed to support the derived       --    instance. As examples, derived 'Generic' instances require       --    associated type family instances, and derived 'Eq' and 'Ord'       --    instances require top-level @con2tag@ functions.-      --    See Note [Auxiliary binders] in TcGenDeriv.+      --    See @Note [Auxiliary binders]@ in "TcGenDeriv".+      --       -- 3. @[Name]@: A list of Names for which @-Wunused-binds@ should be       --    suppressed. This is used to suppress unused warnings for record       --    selectors when deriving 'Read', 'Show', or 'Generic'.-      --    See Note [Deriving and unused record selectors].+      --    See @Note [Deriving and unused record selectors]@.+    } -  | DerivSpecNewtype -- -XGeneralizedNewtypeDeriving-      Type -- The newtype rep type+    -- | @GeneralizedNewtypeDeriving@+  | DerivSpecNewtype+    { dsm_newtype_dit    :: DerivInstTys+      -- ^ Information about the arguments to the class in the derived+      -- instance, including what type constructor the last argument is+      -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@.+    , dsm_newtype_rep_ty :: Type+      -- ^ The newtype rep type.+    } -  | DerivSpecAnyClass -- -XDeriveAnyClass+    -- | @DeriveAnyClass@+  | DerivSpecAnyClass -  | DerivSpecVia -- -XDerivingVia-      Type -- The @via@ type+    -- | @DerivingVia@+  | DerivSpecVia+    { dsm_via_cls_tys :: [Type]+      -- ^ All arguments to the class besides the last one.+    , dsm_via_inst_ty :: Type+      -- ^ The last argument to the class.+    , dsm_via_ty      :: Type+      -- ^ The @via@ type+    }  -- | Convert a 'DerivSpecMechanism' to its corresponding 'DerivStrategy'. derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc-derivSpecMechanismToStrategy DerivSpecStock{}   = StockStrategy-derivSpecMechanismToStrategy DerivSpecNewtype{} = NewtypeStrategy-derivSpecMechanismToStrategy DerivSpecAnyClass  = AnyclassStrategy-derivSpecMechanismToStrategy (DerivSpecVia t)   = ViaStrategy t+derivSpecMechanismToStrategy DerivSpecStock{}               = StockStrategy+derivSpecMechanismToStrategy DerivSpecNewtype{}             = NewtypeStrategy+derivSpecMechanismToStrategy DerivSpecAnyClass              = AnyclassStrategy+derivSpecMechanismToStrategy (DerivSpecVia{dsm_via_ty = t}) = ViaStrategy t  isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia   :: DerivSpecMechanism -> Bool@@ -250,11 +283,117 @@ isDerivSpecVia _                = False  instance Outputable DerivSpecMechanism where-  ppr (DerivSpecStock{})   = text "DerivSpecStock"-  ppr (DerivSpecNewtype t) = text "DerivSpecNewtype" <> colon <+> ppr t-  ppr DerivSpecAnyClass    = text "DerivSpecAnyClass"-  ppr (DerivSpecVia t)     = text "DerivSpecVia" <> colon <+> ppr t+  ppr (DerivSpecStock{dsm_stock_dit = dit})+    = hang (text "DerivSpecStock")+         2 (vcat [ text "dsm_stock_dit" <+> ppr dit ])+  ppr (DerivSpecNewtype { dsm_newtype_dit = dit, dsm_newtype_rep_ty = rep_ty })+    = hang (text "DerivSpecNewtype")+         2 (vcat [ text "dsm_newtype_dit"    <+> ppr dit+                 , text "dsm_newtype_rep_ty" <+> ppr rep_ty ])+  ppr DerivSpecAnyClass = text "DerivSpecAnyClass"+  ppr (DerivSpecVia { dsm_via_cls_tys = cls_tys, dsm_via_inst_ty = inst_ty+                    , dsm_via_ty = via_ty })+    = hang (text "DerivSpecVia")+         2 (vcat [ text "dsm_via_cls_tys" <+> ppr cls_tys+                 , text "dsm_via_inst_ty" <+> ppr inst_ty+                 , text "dsm_via_ty"      <+> ppr via_ty ]) +{-+Note [DerivEnv and DerivSpecMechanism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+DerivEnv contains all of the bits and pieces that are common to every+deriving strategy. (See Note [Deriving strategies] in TcDeriv.) Some deriving+strategies impose stricter requirements on the types involved in the derived+instance than others, and these differences are factored out into the+DerivSpecMechanism type. Suppose that the derived instance looks like this:++  instance ... => C arg_1 ... arg_n++Each deriving strategy imposes restrictions on arg_1 through arg_n as follows:++* stock (DerivSpecStock):++  Stock deriving requires that:++  - n must be a positive number. This is checked by+    TcDeriv.expectNonNullaryClsArgs+  - arg_n must be an application of an algebraic type constructor. Here,+    "algebraic type constructor" means:++    + An ordinary data type constructor, or+    + A data family type constructor such that the arguments it is applied to+      give rise to a data family instance.++    This is checked by TcDeriv.expectAlgTyConApp.++  This extra structure is witnessed by the DerivInstTys data type, which stores+  arg_1 through arg_(n-1) (dit_cls_tys), the algebraic type constructor+  (dit_tc), and its arguments (dit_tc_args). If dit_tc is an ordinary data type+  constructor, then dit_rep_tc/dit_rep_tc_args are the same as+  dit_tc/dit_tc_args. If dit_tc is a data family type constructor, then+  dit_rep_tc is the representation type constructor for the data family+  instance, and dit_rep_tc_args are the arguments to the representation type+  constructor in the corresponding instance.++* newtype (DerivSpecNewtype):++  Newtype deriving imposes the same DerivInstTys requirements as stock+  deriving. This is necessary because we need to know what the underlying type+  that the newtype wraps is, and this information can only be learned by+  knowing dit_rep_tc.++* anyclass (DerivSpecAnyclass):++  DeriveAnyClass is the most permissive deriving strategy of all, as it+  essentially imposes no requirements on the derived instance. This is because+  DeriveAnyClass simply derives an empty instance, so it does not need any+  particular knowledge about the types involved. It can do several things+  that stock/newtype deriving cannot do (#13154):++  - n can be 0. That is, one is allowed to anyclass-derive an instance with+    no arguments to the class, such as in this example:++      class C+      deriving anyclass instance C++  - One can derive an instance for a type that is not headed by a type+    constructor, such as in the following example:++      class C (n :: Nat)+      deriving instance C 0+      deriving instance C 1+      ...++  - One can derive an instance for a data family with no data family instances,+    such as in the following example:++      data family Foo a+      class C a+      deriving anyclass instance C (Foo a)++* via (DerivSpecVia):++  Like newtype deriving, DerivingVia requires that n must be a positive number.+  This is because when one derives something like this:++    deriving via Foo instance C Bar++  Then the generated code must specifically mention Bar. However, in+  contrast with newtype deriving, DerivingVia does *not* require Bar to be+  an application of an algebraic type constructor. This is because the+  generated code simply defers to invoking `coerce`, which does not need to+  know anything in particular about Bar (besides that it is representationally+  equal to Foo). This allows DerivingVia to do some things that are not+  possible with newtype deriving, such as deriving instances for data families+  without data instances (#13154):++    data family Foo a+    newtype ByBar a = ByBar a+    class Baz a where ...+    instance Baz (ByBar a) where ...+    deriving via ByBar (Foo a) instance Baz (Foo a)+-}+ -- | Whether GHC is processing a @deriving@ clause or a standalone deriving -- declaration. data DerivContext@@ -474,7 +613,7 @@ {- Note [Deriving and unused record selectors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (see Trac #13919):+Consider this (see #13919):    module Main (main) where @@ -505,7 +644,7 @@ -- If the TyCon is locally defined, we want the local fixity env; -- but if it is imported (which happens for standalone deriving) -- we need to get the fixity env from the interface file--- c.f. RnEnv.lookupFixity, and Trac #9830+-- c.f. RnEnv.lookupFixity, and #9830 getDataConFixityFun tc   = do { this_mod <- getModule        ; if nameIsLocalOrFrom this_mod name@@ -738,8 +877,10 @@                          (cond_isProduct `andCond` cond_args cls)  cond_args :: Class -> Condition--- For some classes (eg Eq, Ord) we allow unlifted arg types--- by generating specialised code.  For others (eg Data) we don't.+-- ^ For some classes (eg 'Eq', 'Ord') we allow unlifted arg types+-- by generating specialised code.  For others (eg 'Data') we don't.+-- For even others (eg 'Lift'), unlifted types aren't even a special+-- consideration! cond_args cls _ _ rep_tc   = case bad_args of       []     -> IsValid@@ -748,7 +889,7 @@   where     bad_args = [ arg_ty | con <- tyConDataCons rep_tc                         , arg_ty <- dataConOrigArgTys con-                        , isUnliftedType arg_ty+                        , isLiftedType_maybe arg_ty /= Just True                         , not (ok_ty arg_ty) ]      cls_key = classKey cls@@ -756,7 +897,7 @@      | cls_key == eqClassKey   = check_in arg_ty ordOpTbl      | cls_key == ordClassKey  = check_in arg_ty ordOpTbl      | cls_key == showClassKey = check_in arg_ty boxConTbl-     | cls_key == liftClassKey = check_in arg_ty litConTbl+     | cls_key == liftClassKey = True     -- Lift is levity-polymorphic      | otherwise               = False    -- Read, Ix etc      check_in :: Type -> [(Type,a)] -> Bool@@ -801,7 +942,7 @@   = allValid (map check_con data_cons)   where     tc_tvs            = tyConTyVars rep_tc-    Just (_, last_tv) = snocView tc_tvs+    last_tv           = last tc_tvs     bad_stupid_theta  = filter is_bad (tyConStupidTheta rep_tc)     is_bad pred       = last_tv `elemVarSet` exactTyCoVarsOfType pred       -- See Note [Check that the type variable is truly universal]@@ -917,12 +1058,9 @@ This is not restricted to Generics; any class can be derived, simply giving rise to an empty instance. -Unfortunately, it is not clear how to determine the context (when using a-deriving clause; in standalone deriving, the user provides the context).-GHC uses the same heuristic for figuring out the class context that it uses for-Eq in the case of *-kinded classes, and for Functor in the case of-* -> *-kinded classes. That may not be optimal or even wrong. But in such-cases, standalone deriving can still be used.+See Note [Gathering and simplifying constraints for DeriveAnyClass] in+TcDerivInfer for an explanation hof how the instance context is inferred for+DeriveAnyClass.  Note [Check that the type variable is truly universal] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -938,7 +1076,7 @@      T6 :: T a (b,b)            -- No!  'b' is constrained  Notice that only the first of these constructors is vanilla H-98. We only-need to take care about the last argument (b in this case).  See Trac #8678.+need to take care about the last argument (b in this case).  See #8678. Eg. for T1-T3 we can write       fmap f (T1 a b) = T1 a (f b)@@ -970,5 +1108,5 @@ type variable b. But this is OK, because expanding the type synonym C would give us the context (Show a), which doesn't mention b. Therefore, we must make sure to expand type synonyms before performing this check. Not doing so led to-Trac #13813.+#13813. -}
compiler/typecheck/TcEnv.hs view
@@ -4,7 +4,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an                                        -- orphan {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]-                                      -- in module PlaceHolder+                                      -- in module GHC.Hs.PlaceHolder {-# LANGUAGE TypeFamilies #-}  module TcEnv(@@ -25,6 +25,7 @@         tcLookupLocatedGlobalId, tcLookupLocatedTyCon,         tcLookupLocatedClass, tcLookupAxiom,         lookupGlobal, ioLookupDataCon,+        addTypecheckedBinds,          -- Local environment         tcExtendKindEnv, tcExtendKindEnvList,@@ -36,6 +37,7 @@          tcLookup, tcLookupLocated, tcLookupLocalIds,         tcLookupId, tcLookupIdMaybe, tcLookupTyVar,+        tcLookupTcTyCon,         tcLookupLcl_maybe,         getInLocalScope,         wrongThingErr, pprBinders,@@ -56,25 +58,22 @@         -- Defaults         tcGetDefaultTys, -        -- Global type variables-        tcGetGlobalTyCoVars,-         -- Template Haskell stuff         checkWellStaged, tcMetaTy, thLevel,         topIdLvl, isBrackStage,          -- New Ids-        newDFunName, newDFunName', newFamInstTyConName,+        newDFunName, newFamInstTyConName,         newFamInstAxiomName,         mkStableIdFromString, mkStableIdFromName,         mkWrapperName   ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude -import HsSyn+import GHC.Hs import IfaceEnv import TcRnMonad import TcMType@@ -84,7 +83,6 @@ import TysWiredIn import Id import Var-import VarSet import RdrName import InstEnv import DataCon ( DataCon )@@ -106,14 +104,15 @@ import Outputable import Encoding import FastString+import Bag import ListSetOps import ErrUtils-import Util import Maybes( MaybeErr(..), orElse ) import qualified GHC.LanguageExtensions as LangExt+import Util ( HasDebugCallStack )  import Data.IORef-import Data.List+import Data.List (intercalate) import Control.Monad  {- *********************************************************************@@ -187,6 +186,15 @@           pprTcTyThingCategory (AGlobal thing) <+> quotes (ppr name) <+>                 text "used as a data constructor" +addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv+addTypecheckedBinds tcg_env binds+  | isHsBootOrSig (tcg_src tcg_env) = tcg_env+    -- Do not add the code for record-selector bindings+    -- when compiling hs-boot files+  | otherwise = tcg_env { tcg_binds = foldr unionBags+                                            (tcg_binds tcg_env)+                                            binds }+ {- ************************************************************************ *                                                                      *@@ -448,6 +456,13 @@                 Just (ATcId { tct_id = id }) ->  id                 _ -> pprPanic "tcLookupLocalIds" (ppr name) +tcLookupTcTyCon :: HasDebugCallStack => Name -> TcM TcTyCon+tcLookupTcTyCon name = do+    thing <- tcLookup name+    case thing of+        ATcTyCon tc -> return tc+        _           -> pprPanic "tcLookupTcTyCon" (ppr name)+ getInLocalScope :: TcM (Name -> Bool) getInLocalScope = do { lcl_env <- getLclTypeEnv                      ; return (`elemNameEnv` lcl_env) }@@ -576,7 +591,7 @@ -- as free in the types of extra_env.   = do  { traceTc "tc_extend_local_env" (ppr extra_env)         ; env0 <- getLclEnv-        ; env1 <- tcExtendLocalTypeEnv env0 extra_env+        ; let env1 = tcExtendLocalTypeEnv env0 extra_env         ; stage <- getStage         ; let env2 = extend_local_env (top_lvl, thLevel stage) extra_env env1         ; setLclEnv env2 thing_inside }@@ -594,52 +609,9 @@             , tcl_th_bndrs = extendNameEnvList th_bndrs  -- We only track Ids in tcl_th_bndrs                                  [(n, thlvl) | (n, ATcId {}) <- pairs] } -tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcM TcLclEnv+tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things-  | isEmptyVarSet extra_tvs-  = return (lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things })-  | otherwise-  = do { global_tvs <- readMutVar (tcl_tyvars lcl_env)-       ; new_g_var  <- newMutVar (global_tvs `unionVarSet` extra_tvs)-       ; return (lcl_env { tcl_tyvars = new_g_var-                         , tcl_env = extendNameEnvList lcl_type_env tc_ty_things } ) }-  where-    extra_tvs = foldr get_tvs emptyVarSet tc_ty_things--    get_tvs (_, ATcId { tct_id = id, tct_info = closed }) tvs-      = case closed of-          ClosedLet -> ASSERT2( is_closed_type, ppr id $$ ppr (idType id) )-                       tvs-          _other    -> tvs `unionVarSet` id_tvs-        where-           id_ty          = idType id-           id_tvs         = tyCoVarsOfType id_ty-           id_co_tvs      = closeOverKinds (coVarsOfType id_ty)-           is_closed_type = not (anyVarSet isTyVar (id_tvs `minusVarSet` id_co_tvs))-           -- We only care about being closed wrt /type/ variables-           -- E.g. a top-level binding might have a type like-           --          foo :: t |> co-           -- where co :: * ~ *-           -- or some other as-yet-unsolved kind coercion--    get_tvs (_, ATyVar _ tv) tvs          -- See Note [Global TyVars]-      = tvs `unionVarSet` tyCoVarsOfType (tyVarKind tv) `extendVarSet` tv--    get_tvs (_, ATcTyCon tc) tvs = tvs `unionVarSet` tyCoVarsOfType (tyConKind tc)--    get_tvs (_, AGlobal {})       tvs = tvs-    get_tvs (_, APromotionErr {}) tvs = tvs--        -- Note [Global TyVars]-        -- It's important to add the in-scope tyvars to the global tyvar set-        -- as well.  Consider-        --      f (_::r) = let g y = y::r in ...-        -- Here, g mustn't be generalised.  This is also important during-        -- class and instance decls, when we mustn't generalise the class tyvars-        -- when typechecking the methods.-        ---        -- Nor must we generalise g over any kind variables free in r's kind-+  = lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things }  {- ********************************************************************* *                                                                      *@@ -671,7 +643,7 @@             ; tyvar2 <- zonkTcTyVarToTyVar tyvar1               -- Be sure to zonk here!  Tidying applies to zonked               -- types, so if we don't zonk we may create an-              -- ill-kinded type (Trac #14175)+              -- ill-kinded type (#14175)             ; go (env', extendVarEnv subst tyvar tyvar2) bs }       | otherwise       = go (env, subst) bs@@ -706,18 +678,18 @@     get_cons (L _ (DataFamInstD { dfid_inst = fid }))  = get_fi_cons fid     get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))       = concatMap (get_fi_cons . unLoc) fids-    get_cons (L _ (ClsInstD _ (XClsInstDecl _))) = panic "get_cons"-    get_cons (L _ (XInstDecl _)) = panic "get_cons"+    get_cons (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec+    get_cons (L _ (XInstDecl nec)) = noExtCon nec      get_fi_cons :: DataFamInstDecl GhcRn -> [Name]     get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =                   FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}})       = map unLoc $ concatMap (getConNames . unLoc) cons     get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =-                  FamEqn { feqn_rhs = XHsDataDefn _ }}})-      = panic "get_fi_cons"-    get_fi_cons (DataFamInstDecl (HsIB _ (XFamEqn _))) = panic "get_fi_cons"-    get_fi_cons (DataFamInstDecl (XHsImplicitBndrs _)) = panic "get_fi_cons"+                  FamEqn { feqn_rhs = XHsDataDefn nec }}})+      = noExtCon nec+    get_fi_cons (DataFamInstDecl (HsIB _ (XFamEqn nec))) = noExtCon nec+    get_fi_cons (DataFamInstDecl (XHsImplicitBndrs nec)) = noExtCon nec   tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a@@ -758,20 +730,20 @@ constructors, bound to AFamDataCon, so that if we trip over 'MkT' when type checking 'S' we'll produce a decent error message. -Trac #12088 describes this limitation. Of course, when MkT and S live in+#12088 describes this limitation. Of course, when MkT and S live in different modules then all is well.  Note [Don't promote pattern synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We never promote pattern synonyms. -Consider this (Trac #11265):+Consider this (#11265):   pattern A = True   instance Eq A We want a civilised error message from the occurrence of 'A' in the instance, yet 'A' really has not yet been type checked. -Similarly (Trac #9161)+Similarly (#9161)   {-# LANGUAGE PatternSynonyms, DataKinds #-}   pattern A = ()   b :: A@@ -879,7 +851,7 @@   = do  { dflags <- getDynFlags         ; let ovl_strings = xopt LangExt.OverloadedStrings dflags               extended_defaults = xopt LangExt.ExtendedDefaultRules dflags-                                        -- See also Trac #1974+                                        -- See also #1974               flags = (ovl_strings, extended_defaults)          ; mb_defaults <- getDeclaredDefaultTys@@ -913,7 +885,7 @@ want the GHCi repl loop to try to print that 'undefined'.  The neatest thing is to default the 'a' to (), rather than to Integer (which is what would otherwise happen; and then GHCi doesn't attempt to print the ().  So in interactive mode, we add-() to the list of defaulting types.  See Trac #1200.+() to the list of defaulting types.  See #1200.  Additionally, the list type [] is added as a default specialization for Traversable and Foldable. As such the default default list now has types of@@ -970,11 +942,11 @@            --          Used only to improve error messages       } -instance (OutputableBndrId (GhcPass a))+instance (OutputableBndrId a)        => Outputable (InstInfo (GhcPass a)) where     ppr = pprInstInfoDetails -pprInstInfoDetails :: (OutputableBndrId (GhcPass a))+pprInstInfoDetails :: (OutputableBndrId a)                    => InstInfo (GhcPass a) -> SDoc pprInstInfoDetails info    = hang (pprInstanceHdr (iSpec info) <+> text "where")@@ -1007,21 +979,6 @@         ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)         ; newGlobalBinder mod dfun_occ loc } --- | Special case of 'newDFunName' to generate dict fun name for a single TyCon.-newDFunName' :: Class -> TyCon -> TcM Name-newDFunName' clas tycon        -- Just a simple wrapper-  = do { loc <- getSrcSpanM     -- The location of the instance decl,-                                -- not of the tycon-       ; newDFunName clas [mkTyConApp tycon []] loc }-       -- The type passed to newDFunName is only used to generate-       -- a suitable string; hence the empty type arg list--{--Make a name for the representation tycon of a family instance.  It's an-*external* name, like other top-level names, and hence must be made with-newGlobalBinder.--}- newFamInstTyConName :: Located Name -> [Type] -> TcM Name newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys] @@ -1112,7 +1069,7 @@        ; case stage of   -- See Note [Out of scope might be a staging error]            Splice {}              | isUnboundName name -> failM  -- If the name really isn't in scope-                                            -- don't report it again (Trac #11941)+                                            -- don't report it again (#11941)              | otherwise -> stageRestrictionError (quotes (ppr name))            _ -> failWithTc $                 vcat[text "GHC internal error:" <+> quotes (ppr name) <+>@@ -1145,5 +1102,5 @@ But in fact the type checker processes types first, so 'x' won't even be in the type envt when we look for it in $(foo x).  So inside splices we report something missing from the type env as a staging error.-See Trac #5752 and #5795.+See #5752 and #5795. -}
compiler/typecheck/TcErrors.hs view
@@ -9,19 +9,23 @@        solverDepthErrorTcS   ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import TcRnTypes import TcRnMonad+import Constraint+import Predicate import TcMType-import TcUnify( occCheckForErrors, OccCheckResult(..) )+import TcUnify( occCheckForErrors, MetaTyVarUpdateResult(..) ) import TcEnv( tcInitTidyEnv ) import TcType+import TcOrigin import RnUnbound ( unknownNameSuggestions ) import Type import TyCoRep+import TyCoPpr          ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE ) import Unify            ( tcMatchTys ) import Module import FamInst@@ -33,8 +37,8 @@ import DataCon import TcEvidence import TcEvTerm-import HsExpr  ( UnboundVar(..) )-import HsBinds ( PatSynBind(..) )+import GHC.Hs.Expr  ( UnboundVar(..) )+import GHC.Hs.Binds ( PatSynBind(..) ) import Name import RdrName ( lookupGlobalRdrEnv, lookupGRE_Name, GlobalRdrEnv                , mkRdrUnqual, isLocalGRE, greSrcSpan )@@ -227,7 +231,7 @@                                  -- See Note [Suppressing error messages]                                  -- Suppress low-priority errors if there                                  -- are insolule errors anywhere;-                                 -- See Trac #15539 and c.f. setting ic_status+                                 -- See #15539 and c.f. setting ic_status                                  -- in TcSimplify.setImplicationStatus                             , cec_warn_redundant = warn_redundant                             , cec_binds    = binds_var }@@ -389,7 +393,7 @@  But we need to take care: flags can turn errors into warnings, and we don't want those warnings to suppress subsequent errors (including-suppressing the essential addTcEvBind for them: Trac #15152). So in+suppressing the essential addTcEvBind for them: #15152). So in tryReporter we use askNoErrs to see if any error messages were /actually/ produced; if not, we don't switch on suppression. @@ -418,7 +422,7 @@          warnRedundantConstraints ctxt' tcl_env info' dead_givens        ; when bad_telescope $ reportBadTelescope ctxt tcl_env m_telescope tvs }   where-    tcl_env      = implicLclEnv implic+    tcl_env      = ic_env implic     insoluble    = isInsolubleStatus status     (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) tvs     info'        = tidySkolemInfo env1 info@@ -432,7 +436,7 @@           -- type errors.  You could imagine using the /enclosing/           -- bindings (in cec_binds), but that may not have enough stuff           -- in scope for the bindings to be well typed.  So we just-          -- switch off deferred type errors altogether.  See Trac #14605.+          -- switch off deferred type errors altogether.  See #14605.      ctxt' = ctxt1 { cec_tidy     = env1                   , cec_encl     = implic' : cec_encl ctxt@@ -441,7 +445,7 @@                         -- Suppress inessential errors if there                         -- are insolubles anywhere in the                         -- tree rooted here, or we've come across-                        -- a suppress-worthy constraint higher up (Trac #11541)+                        -- a suppress-worthy constraint higher up (#11541)                    , cec_binds    = evb } @@ -505,7 +509,7 @@ {- Note [Redundant constraints in instance decls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For instance declarations, we don't report unused givens if-they can give rise to improvement.  Example (Trac #10100):+they can give rise to improvement.  Example (#10100):     class Add a b ab | a b -> ab, a ab -> b     instance Add Zero b b     instance Add a b ab => Add (Succ a) b (Succ ab)@@ -583,7 +587,7 @@      -- rigid_nom_eq, rigid_nom_tv_eq,     is_hole, is_dict,-      is_equality, is_ip, is_irred :: Ct -> PredTree -> Bool+      is_equality, is_ip, is_irred :: Ct -> Pred -> Bool      is_given_eq ct pred        | EqPred {} <- pred = arisesFromGivens ct@@ -635,14 +639,14 @@           -- Reason: we don't report all given errors           --         (see mkGivenErrorReporter), and we should only suppress           --         subsequent errors if we actually report this one!-          --         Trac #13446 is an example+          --         #13446 is an example      -- See Note [Given errors]     has_gadt_match [] = False     has_gadt_match (implic : implics)       | PatSkol {} <- ic_info implic       , not (ic_no_eqs implic)-      , wopt Opt_WarnInaccessibleCode (implicDynFlags implic)+      , ic_warn_inaccessible implic           -- Don't bother doing this if -Winaccessible-code isn't enabled.           -- See Note [Avoid -Winaccessible-code when deriving] in TcInstDcls.       = True@@ -675,7 +679,7 @@   = ReportErrCtxt -> [Ct] -> TcM () type ReporterSpec   = ( String                     -- Name-    , Ct -> PredTree -> Bool     -- Pick these ones+    , Ct -> Pred -> Bool         -- Pick these ones     , Bool                       -- True <=> suppress subsequent reporters     , Reporter)                  -- The reporter itself @@ -723,7 +727,7 @@        ; dflags <- getDynFlags        ; let (implic:_) = cec_encl ctxt                  -- Always non-empty when mkGivenErrorReporter is called-             ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (implicLclEnv implic))+             ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic))                    -- For given constraints we overwrite the env (and hence src-loc)                    -- with one from the immediately-enclosing implication.                    -- See Note [Inaccessible code]@@ -824,7 +828,7 @@                             -- Add deferred bindings for all                             -- Redundant if we are going to abort compilation,                             -- but that's hard to know for sure, and if we don't-                            -- abort, we need bindings for all (e.g. Trac #12156)+                            -- abort, we need bindings for all (e.g. #12156)   where     isMonadFailInstanceMissing ct =         case ctLocOrigin (ctLoc ct) of@@ -837,11 +841,11 @@ maybeReportHoleError ctxt ct err   -- When -XPartialTypeSignatures is on, warnings (instead of errors) are   -- generated for holes in partial type signatures.-  -- Unless -fwarn_partial_type_signatures is not on,+  -- Unless -fwarn-partial-type-signatures is not on,   -- in which case the messages are discarded.   | isTypeHoleCt ct   = -- For partial type signatures, generate warnings only, and do that-    -- only if -fwarn_partial_type_signatures is on+    -- only if -fwarn-partial-type-signatures is on     case cec_type_holes ctxt of        HoleError -> reportError err        HoleWarn  -> reportWarning (Reason Opt_WarnPartialTypeSignatures) err@@ -850,7 +854,7 @@   -- Always report an error for out-of-scope variables   -- Unless -fdefer-out-of-scope-variables is on,   -- in which case the messages are discarded.-  -- See Trac #12170, #12406+  -- See #12170, #12406   | isOutOfScopeCt ct   = -- If deferring, report a warning only if -Wout-of-scope-variables is on     case cec_out_of_scope_holes ctxt of@@ -1165,7 +1169,7 @@ mkHoleError tidy_simples ctxt ct@(CHoleCan { cc_hole = hole })   -- Explicit holes, like "_" or "_f"   = do { (ctxt, binds_msg, ct) <- relevantBindings False ctxt ct-               -- The 'False' means "don't filter the bindings"; see Trac #8191+               -- The 'False' means "don't filter the bindings"; see #8191         ; show_hole_constraints <- goptM Opt_ShowHoleConstraints        ; let constraints_msg@@ -1263,7 +1267,7 @@         constraints =           do { implic@Implic{ ic_given = given } <- cec_encl ctxt              ; constraint <- given-             ; return (varType constraint, tcl_loc (implicLclEnv implic)) }+             ; return (varType constraint, tcl_loc (ic_env implic)) }          pprConstraint (constraint, loc) =           ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc))@@ -1439,13 +1443,13 @@ Here the second equation is unreachable. The original constraint (a~Int) from the signature gets rewritten by the pattern-match to (Bool~Int), so the danger is that we report the error as coming from-the *signature* (Trac #7293).  So, for Given errors we replace the+the *signature* (#7293).  So, for Given errors we replace the env (and hence src-loc) on its CtLoc with that from the immediately enclosing implication.  Note [Error messages for untouchables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (Trac #9109)+Consider (#9109)   data G a where { GBool :: G Bool }   foo x = case x of GBool -> True @@ -1640,7 +1644,7 @@         , report         ] -  | OC_Occurs <- occ_check_expand+  | MTVU_Occurs <- occ_check_expand     -- We report an "occurs check" even for  a ~ F t a, where F is a type     -- function; it's not insoluble (because in principle F could reduce)     -- but we have certainly been unable to solve it@@ -1665,10 +1669,10 @@        ; mkErrorMsgFromCt ctxt ct $          mconcat [important main_msg, extra2, extra3, report] } -  | OC_Bad <- occ_check_expand+  | MTVU_Bad <- occ_check_expand   = do { let msg = vcat [ text "Cannot instantiate unification variable"                           <+> quotes (ppr tv1)-                        , hang (text "with a" <+> what <+> text "involving foralls:") 2 (ppr ty2)+                        , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2)                         , nest 2 (text "GHC doesn't yet support impredicative polymorphism") ]        -- Unlike the other reports, this discards the old 'report_important'        -- instead of augmenting it.  This is because the details are not likely@@ -1726,7 +1730,7 @@                                <+> text "bound by"                              , nest 2 $ ppr skol_info                              , nest 2 $ text "at" <+>-                               ppr (tcl_loc (implicLclEnv implic)) ] ]+                               ppr (tcl_loc (ic_env implic)) ] ]        ; mkErrorMsgFromCt ctxt ct (mconcat [msg, tv_extra, report]) }    -- Nastiest case: attempt to unify an untouchable variable@@ -1745,7 +1749,7 @@                       , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given                       , nest 2 $ text "bound by" <+> ppr skol_info                       , nest 2 $ text "at" <+>-                        ppr (tcl_loc (implicLclEnv implic)) ]+                        ppr (tcl_loc (ic_env implic)) ]              tv_extra = important $ extraTyVarEqInfo ctxt tv1 ty2              add_sig  = important $ suggestAddSig ctxt ty1 ty2        ; mkErrorMsgFromCt ctxt ct $ mconcat@@ -1753,7 +1757,7 @@    | otherwise   = reportEqErr ctxt report ct oriented (mkTyVarTy tv1) ty2-        -- This *can* happen (Trac #6123, and test T2627b)+        -- This *can* happen (#6123, and test T2627b)         -- Consider an ambiguous top-level constraint (a ~ F a)         -- Not an occurs check, because F is a type function.   where@@ -1840,7 +1844,7 @@              -- See Note [Suppress redundant givens during error reporting]              -- for why we use mkMinimalBySCs above.                 2 (sep [ text "bound by" <+> ppr skol_info-                       , text "at" <+> ppr (tcl_loc (implicLclEnv implic)) ])+                       , text "at" <+> ppr (tcl_loc (ic_env implic)) ])  {- Note [Suppress redundant givens during error reporting]@@ -1983,17 +1987,16 @@ -- themselves. pprWithExplicitKindsWhenMismatch :: Type -> Type -> CtOrigin                                  -> SDoc -> SDoc-pprWithExplicitKindsWhenMismatch ty1 ty2 ct =-  pprWithExplicitKindsWhen mismatch+pprWithExplicitKindsWhenMismatch ty1 ty2 ct+  = pprWithExplicitKindsWhen show_kinds   where     (act_ty, exp_ty) = case ct of       TypeEqOrigin { uo_actual = act                    , uo_expected = exp } -> (act, exp)       _                                  -> (ty1, ty2)-    mismatch | Just vis <- tcEqTypeVis act_ty exp_ty-             = not vis-             | otherwise-             = False+    show_kinds = tcEqTypeVis act_ty exp_ty+                 -- True when the visible bit of the types look the same,+                 -- so we want to show the kinds in the displayed type  mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool                     -> (Bool, Maybe SwapFlag, SDoc)@@ -2016,11 +2019,11 @@     level = m_level `orElse` TypeLevel      occurs_check_error-      | Just act_tv <- tcGetTyVar_maybe act-      , act_tv `elemVarSet` tyCoVarsOfType exp+      | Just tv <- tcGetTyVar_maybe ty1+      , tv `elemVarSet` tyCoVarsOfType ty2       = True-      | Just exp_tv <- tcGetTyVar_maybe exp-      , exp_tv `elemVarSet` tyCoVarsOfType act+      | Just tv <- tcGetTyVar_maybe ty2+      , tv `elemVarSet` tyCoVarsOfType ty1       = True       | otherwise       = False@@ -2044,13 +2047,17 @@         -> empty      thing_msg = case maybe_thing of-                  Just thing -> \_ -> quotes thing <+> text "is"-                  Nothing    -> \vowel -> text "got a" <>-                                          if vowel then char 'n' else empty+                  Just thing -> \_ levity ->+                    quotes thing <+> text "is" <+> levity+                  Nothing    -> \vowel levity ->+                    text "got a" <>+                    (if vowel then char 'n' else empty) <+>+                    levity <+>+                    text "type"     msg2 = sep [ text "Expecting a lifted type, but"-               , thing_msg True, text "unlifted" ]+               , thing_msg True (text "unlifted") ]     msg3 = sep [ text "Expecting an unlifted type, but"-               , thing_msg False, text "lifted" ]+               , thing_msg False (text "lifted") ]     msg4 = maybe_num_args_msg $$            sep [ text "Expected a type, but"                , maybe (text "found something with kind")@@ -2115,7 +2122,7 @@  {- Note [Insoluble occurs check wins] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider [G] a ~ [a],  [W] a ~ [a] (Trac #13674).  The Given is insoluble+Consider [G] a ~ [a],  [W] a ~ [a] (#13674).  The Given is insoluble so we don't use it for rewriting.  The Wanted is also insoluble, and we don't solve it from the Given.  It's very confusing to say     Cannot solve a ~ [a] from given constraints a ~ [a]@@ -2208,10 +2215,11 @@           (t1_2', t2_2') = go t1_2 t2_2        in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2') -    go (FunTy t1_1 t1_2) (FunTy t2_1 t2_2) =+    go ty1@(FunTy _ t1_1 t1_2) ty2@(FunTy _ t2_1 t2_2) =       let (t1_1', t2_1') = go t1_1 t2_1           (t1_2', t2_2') = go t1_2 t2_2-       in (mkFunTy t1_1' t1_2', mkFunTy t2_1' t2_2')+       in ( ty1 { ft_arg = t1_1', ft_res = t1_2' }+          , ty2 { ft_arg = t2_1', ft_res = t2_2' })      go (ForAllTy b1 t1) (ForAllTy b2 t2) =       -- NOTE: We may have a bug here, but we just can't reproduce it easily.@@ -2325,11 +2333,11 @@ type variable is bound by an *inferred* signature, and suggests adding a declared signature instead. -This initially came up in Trac #8968, concerning pattern synonyms.+This initially came up in #8968, concerning pattern synonyms.  Note [Disambiguating (X ~ X) errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See Trac #8278+See #8278  Note [Reporting occurs-check errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2584,16 +2592,16 @@              _  -> Just $ hang (pprTheta ev_vars_matching)                             2 (sep [ text "bound by" <+> ppr skol_info                                    , text "at" <+>-                                     ppr (tcl_loc (implicLclEnv implic)) ])-        where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)-              ev_var_matches ty = case getClassPredTys_maybe ty of-                 Just (clas', tys')-                   | clas' == clas-                   , Just _ <- tcMatchTys tys tys'-                   -> True-                   | otherwise-                   -> any ev_var_matches (immSuperClasses clas' tys')-                 Nothing -> False+                                     ppr (tcl_loc (ic_env implic)) ])+        where ev_vars_matching = [ pred+                                 | ev_var <- evvars+                                 , let pred = evVarPred ev_var+                                 , any can_match (pred : transSuperClasses pred) ]+              can_match pred+                 = case getClassPredTys_maybe pred of+                     Just (clas', tys') -> clas' == clas+                                          && isJust (tcMatchTys tys tys')+                     Nothing -> False      -- Overlap error because of Safe Haskell (first     -- match should be the most specific match)@@ -2677,7 +2685,7 @@     No instance for (Num Int) arising from the literal ‘3’     There are instances for similar types:       instance Num GHC.Types.Int -- Defined in ‘GHC.Num’-Discussion in Trac #9611.+Discussion in #9611.  Note [Highlighting ambiguous type variables] ~-------------------------------------------@@ -2724,7 +2732,7 @@  So we suppress that Implication in discardProvCtxtGivens.  It's painfully ad-hoc but the truth is that adding it to the "required"-constraints would work.  Suprressing it solves two problems.  First,+constraints would work.  Suppressing it solves two problems.  First, we never tell the user that we could not deduce a "provided" constraint from the "required" context. Second, we never give a possible fix that suggests to add a "provided" constraint to the@@ -2843,7 +2851,7 @@  Note [Kind arguments in error messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It can be terribly confusing to get an error message like (Trac #9171)+It can be terribly confusing to get an error message like (#9171)      Couldn't match expected type ‘GetParam Base (GetParam Base Int)’                 with actual type ‘GetParam Base (GetParam Base Int)’@@ -2947,10 +2955,10 @@ -- We must be careful to pass it a zonked type variable, too. -- -- We always remove closed top-level bindings, though,--- since they are never relevant (cf Trac #8233)+-- since they are never relevant (cf #8233)  relevantBindings :: Bool  -- True <=> filter by tyvar; False <=> no filtering-                          -- See Trac #8191+                          -- See #8191                  -> ReportErrCtxt -> Ct                  -> TcM (ReportErrCtxt, SDoc, Ct) -- Also returns the zonked and tidied CtOrigin of the constraint
compiler/typecheck/TcEvTerm.hs view
@@ -29,7 +29,7 @@     Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg]   where     errorId = tYPE_ERROR_ID-    litMsg  = Lit (LitString (fastStringToByteString msg))+    litMsg  = Lit (LitString (bytesFS msg))  -- Dictionary for CallStack implicit parameters evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>
compiler/typecheck/TcExpr.hs view
@@ -17,14 +17,14 @@                 addExprErrCtxt,                 getFixedTyVars ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import {-# SOURCE #-}   TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket ) import THNames( liftStringName, liftName ) -import HsSyn+import GHC.Hs import TcHsSyn import TcRnMonad import TcUnify@@ -44,6 +44,7 @@ import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr ) import TcPat import TcMType+import TcOrigin import TcType import Id import IdInfo@@ -56,12 +57,13 @@ import RdrName import TyCon import TyCoRep+import TyCoPpr+import TyCoSubst (substTyWithInScope) import Type import TcEvidence import VarSet-import MkId( seqId ) import TysWiredIn-import TysPrim( intPrimTy, mkTemplateTyVars, tYPE )+import TysPrim( intPrimTy ) import PrimOp( tagToEnumKey ) import PrelNames import DynFlags@@ -78,7 +80,7 @@ import qualified GHC.LanguageExtensions as LangExt  import Data.Function-import Data.List+import Data.List (partition, sortBy, groupBy, intersect) import qualified Data.Set as Set  {-@@ -211,7 +213,7 @@        ; ipClass <- tcLookupClass ipClassName        ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])        ; tcWrapResult e-                   (fromDict ipClass ip_name ip_ty (HsVar noExt (noLoc ip_var)))+                   (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLoc ip_var)))                    ip_ty res_ty }   where   -- Coerces a dictionary for `IP "x" t` into `t`.@@ -230,7 +232,7 @@                          ; loc <- getSrcSpanM                          ; var <- emitWantedEvVar origin pred                          ; tcWrapResult e-                                       (fromDict pred (HsVar noExt (L loc var)))+                                       (fromDict pred (HsVar noExtField (L loc var)))                                         alpha res_ty } }   where   -- Coerces a dictionary for `IsLabel "x" t` into `t`,@@ -240,9 +242,9 @@   lbl = mkStrLitTy l    applyFromLabel loc fromLabel =-    HsAppType noExt-         (L loc (HsVar noExt (L loc fromLabel)))-         (mkEmptyWildCardBndrs (L loc (HsTyLit noExt (HsStrTy NoSourceText l))))+    HsAppType noExtField+         (L loc (HsVar noExtField (L loc fromLabel)))+         (mkEmptyWildCardBndrs (L loc (HsTyLit noExtField (HsStrTy NoSourceText l))))  tcExpr (HsLam x match) res_ty   = do  { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty@@ -271,7 +273,7 @@        ; sig_info <- checkNoErrs $  -- Avoid error cascade                      tcUserTypeSig loc sig_ty Nothing        ; (expr', poly_ty) <- tcExprSig expr sig_info-       ; let expr'' = ExprWithTySig noExt expr' sig_ty+       ; let expr'' = ExprWithTySig noExtField expr' sig_ty        ; tcWrapResult e expr'' poly_ty res_ty }  {-@@ -331,40 +333,10 @@   * Decompose it; should be of form (arg2_ty -> res_ty),        where arg2_ty might be a polytype   * Use arg2_ty to typecheck arg2--Note [Typing rule for seq]-~~~~~~~~~~~~~~~~~~~~~~~~~~-We want to allow-       x `seq` (# p,q #)-which suggests this type for seq:-   seq :: forall (a:*) (b:Open). a -> b -> b,-with (b:Open) meaning that be can be instantiated with an unboxed-tuple.  The trouble is that this might accept a partially-applied-'seq', and I'm just not certain that would work.  I'm only sure it's-only going to work when it's fully applied, so it turns into-    case x of _ -> (# p,q #)--So it seems more uniform to treat 'seq' as if it was a language-construct.--See also Note [seqId magic] in MkId -}  tcExpr expr@(OpApp fix arg1 op arg2) res_ty   | (L loc (HsVar _ (L lv op_name))) <- op-  , op_name `hasKey` seqIdKey           -- Note [Typing rule for seq]-  = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind-       ; let arg2_exp_ty = res_ty-       ; arg1' <- tcArg op arg1 arg1_ty 1-       ; arg2' <- addErrCtxt (funAppCtxt op arg2 2) $-                  tc_poly_expr_nc arg2 arg2_exp_ty-       ; arg2_ty <- readExpType arg2_exp_ty-       ; op_id <- tcLookupId op_name-       ; let op' = L loc (mkHsWrap (mkWpTyApps [arg1_ty, arg2_ty])-                                   (HsVar noExt (L lv op_id)))-       ; return $ OpApp fix arg1' op' arg2' }--  | (L loc (HsVar _ (L lv op_name))) <- op   , op_name `hasKey` dollarIdKey        -- Note [Typing rule for ($)]   = do { traceTc "Application rule" (ppr op)        ; (arg1', arg1_ty) <- tcInferSigma arg1@@ -378,49 +350,42 @@          -- So: arg1_ty = arg2_ty -> op_res_ty          -- where arg2_sigma maybe polymorphic; that's the point -       ; arg2'  <- tcArg op arg2 arg2_sigma 2+       ; arg2' <- tcArg op arg2 arg2_sigma 2         -- Make sure that the argument type has kind '*'        --   ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b-       -- Eg we do not want to allow  (D#  $  4.0#)   Trac #5570+       -- Eg we do not want to allow  (D#  $  4.0#)   #5570        --    (which gives a seg fault)-       ---       -- The *result* type can have any kind (Trac #8739),-       -- so we don't need to check anything for that        ; _ <- unifyKind (Just (XHsType $ NHsCoreTy arg2_sigma))                         (tcTypeKind arg2_sigma) liftedTypeKind-           -- ignore the evidence. arg2_sigma must have type * or #,-           -- because we know arg2_sigma -> or_res_ty is well-kinded+           -- Ignore the evidence. arg2_sigma must have type * or #,+           -- because we know (arg2_sigma -> op_res_ty) is well-kinded            -- (because otherwise matchActualFunTys would fail)-           -- There's no possibility here of, say, a kind family reducing to *.+           -- So this 'unifyKind' will either succeed with Refl, or will+           -- produce an insoluble constraint * ~ #, which we'll report later. -       ; wrap_res <- tcSubTypeHR orig1 (Just expr) op_res_ty res_ty-                       -- op_res -> res+       -- NB: unlike the argument type, the *result* type, op_res_ty can+       -- have any kind (#8739), so we don't need to check anything for that         ; op_id  <- tcLookupId op_name-       ; res_ty <- readExpType res_ty-       ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep res_ty+       ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep op_res_ty                                                , arg2_sigma-                                               , res_ty])-                                   (HsVar noExt (L lv op_id)))+                                               , op_res_ty])+                                   (HsVar noExtField (L lv op_id)))              -- arg1' :: arg1_ty              -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty)-             -- wrap_res :: op_res_ty "->" res_ty-             -- op' :: (a2_ty -> res_ty) -> a2_ty -> res_ty+             -- op' :: (a2_ty -> op_res_ty) -> a2_ty -> op_res_ty -             -- wrap1 :: arg1_ty "->" (arg2_sigma -> res_ty)-             wrap1 = mkWpFun idHsWrapper wrap_res arg2_sigma res_ty doc-                     <.> wrap_arg1-             doc = text "When looking at the argument to ($)"+             expr' = OpApp fix (mkLHsWrap wrap_arg1 arg1') op' arg2' -       ; return (OpApp fix (mkLHsWrap wrap1 arg1') op' arg2') }+       ; tcWrapResult expr expr' op_res_ty res_ty }    | (L loc (HsRecFld _ (Ambiguous _ lbl))) <- op   , Just sig_ty <- obviousSig (unLoc arg1)     -- See Note [Disambiguating record fields]   = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty        ; sel_name <- disambiguateSelector lbl sig_tc_ty-       ; let op' = L loc (HsRecFld noExt (Unambiguous sel_name lbl))+       ; let op' = L loc (HsRecFld noExtField (Unambiguous sel_name lbl))        ; tcExpr (OpApp fix arg1 op' arg2) res_ty        } @@ -439,7 +404,7 @@        ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty)                   <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op)) 2 op_ty        ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)-                                 (mkFunTy arg1_ty op_res_ty) res_ty+                                 (mkVisFunTy arg1_ty op_res_ty) res_ty        ; arg2' <- tcArg op arg2 arg2_ty 2        ; return ( mkHsWrap wrap_res $                   SectionR x (mkLHsWrap wrap_fun op') arg2' ) }@@ -447,7 +412,7 @@     fn_orig = lexprCtOrigin op     -- It's important to use the origin of 'op', so that call-stacks     -- come out right; they are driven by the OccurrenceOf CtOrigin-    -- See Trac #13285+    -- See #13285  tcExpr expr@(SectionL x arg1 op) res_ty   = do { (op', op_ty) <- tcInferFun op@@ -459,7 +424,7 @@            <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op))                                 n_reqd_args op_ty        ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)-                                 (mkFunTys arg_tys op_res_ty) res_ty+                                 (mkVisFunTys arg_tys op_res_ty) res_ty        ; arg1' <- tcArg op arg1 arg1_ty 1        ; return ( mkHsWrap wrap_res $                   SectionL x arg1' (mkLHsWrap wrap_fn op') ) }@@ -467,12 +432,14 @@     fn_orig = lexprCtOrigin op     -- It's important to use the origin of 'op', so that call-stacks     -- come out right; they are driven by the OccurrenceOf CtOrigin-    -- See Trac #13285+    -- See #13285  tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty   | all tupArgPresent tup_args   = do { let arity  = length tup_args              tup_tc = tupleTyCon boxity arity+               -- NB: tupleTyCon doesn't flatten 1-tuples+               -- See Note [Don't flatten tuples from HsSyn] in MkCore        ; res_ty <- expTypeToType res_ty        ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty                            -- Unboxed tuples have RuntimeRep vars, which we@@ -491,8 +458,9 @@            { Boxed   -> newFlexiTyVarTys arity liftedTypeKind            ; Unboxed -> replicateM arity newOpenFlexiTyVarTy }        ; let actual_res_ty-                 = mkFunTys [ty | (ty, (L _ (Missing _))) <- arg_tys `zip` tup_args]-                            (mkTupleTy boxity arg_tys)+                 = mkVisFunTys [ty | (ty, (L _ (Missing _))) <- arg_tys `zip` tup_args]+                            (mkTupleTy1 boxity arg_tys)+                   -- See Note [Don't flatten tuples from HsSyn] in MkCore         ; wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "ExpTuple")                              (Just expr)@@ -512,6 +480,8 @@        ; expr' <- tcPolyExpr expr (arg_tys' `getNth` (alt - 1))        ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) } +-- This will see the empty list only when -XOverloadedLists.+-- See Note [Empty lists] in GHC.Hs.Expr. tcExpr (ExplicitList _ witness exprs) res_ty   = case witness of       Nothing   -> do  { res_ty <- expTypeToType res_ty@@ -639,10 +609,11 @@         ; emitStaticConstraints lie          -- Wrap the static form with the 'fromStaticPtr' call.-        ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName p_ty+        ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName+                                             [p_ty]         ; let wrap = mkWpTyApps [expr_ty]         ; loc <- getSrcSpanM-        ; return $ mkHsWrapCo co $ HsApp noExt+        ; return $ mkHsWrapCo co $ HsApp noExtField                                          (L loc $ mkHsWrap wrap fromStaticPtr)                                          (L loc (HsStatic fvs expr'))         }@@ -700,7 +671,7 @@ not (T a b c),   because 'b' *is not* mentioned in a non-updated field not (T a b' c'), because 'c' *is*     mentioned in a non-updated field NB that it's not good enough to look at just one constructor; we must-look at them all; cf Trac #3219+look at them all; cf #3219  After all, upd should be equivalent to:         upd t x = case t of@@ -1040,7 +1011,7 @@   = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty        ; expr' <- tcPolyExpr expr elt_ty        ; enum_from <- newMethodFromName (ArithSeqOrigin seq)-                              enumFromName elt_ty+                              enumFromName [elt_ty]        ; return $ mkHsWrap wrap $          ArithSeq enum_from wit' (From expr') } @@ -1049,7 +1020,7 @@        ; expr1' <- tcPolyExpr expr1 elt_ty        ; expr2' <- tcPolyExpr expr2 elt_ty        ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)-                              enumFromThenName elt_ty+                              enumFromThenName [elt_ty]        ; return $ mkHsWrap wrap $          ArithSeq enum_from_then wit' (FromThen expr1' expr2') } @@ -1058,7 +1029,7 @@        ; expr1' <- tcPolyExpr expr1 elt_ty        ; expr2' <- tcPolyExpr expr2 elt_ty        ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)-                              enumFromToName elt_ty+                              enumFromToName [elt_ty]        ; return $ mkHsWrap wrap $          ArithSeq enum_from_to wit' (FromTo expr1' expr2') } @@ -1068,7 +1039,7 @@         ; expr2' <- tcPolyExpr expr2 elt_ty         ; expr3' <- tcPolyExpr expr3 elt_ty         ; eft <- newMethodFromName (ArithSeqOrigin seq)-                              enumFromThenToName elt_ty+                              enumFromThenToName [elt_ty]         ; return $ mkHsWrap wrap $           ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') } @@ -1093,7 +1064,7 @@ ************************************************************************ -} --- HsArg is defined in HsTypes.hs+-- HsArg is defined in GHC.Hs.Types  wrapHsArgs :: (NoGhcTc (GhcPass id) ~ GhcRn)            => LHsExpr (GhcPass id)@@ -1102,13 +1073,17 @@ wrapHsArgs f []                     = f wrapHsArgs f (HsValArg  a : args)   = wrapHsArgs (mkHsApp f a)          args wrapHsArgs f (HsTypeArg _ t : args) = wrapHsArgs (mkHsAppType f t)      args-wrapHsArgs f (HsArgPar sp : args)   = wrapHsArgs (L sp $ HsPar noExt f) args+wrapHsArgs f (HsArgPar sp : args)   = wrapHsArgs (L sp $ HsPar noExtField f) args  isHsValArg :: HsArg tm ty -> Bool isHsValArg (HsValArg {})  = True isHsValArg (HsTypeArg {}) = False isHsValArg (HsArgPar {})  = False +isHsTypeArg :: HsArg tm ty -> Bool+isHsTypeArg (HsTypeArg {}) = True+isHsTypeArg _              = False+ isArgPar :: HsArg tm ty -> Bool isArgPar (HsArgPar {})  = True isArgPar (HsValArg {})  = False@@ -1154,39 +1129,14 @@        ; (tc_fun, fun_ty) <- tcInferRecSelId (Unambiguous sel_name lbl)        ; tcFunApp m_herald fun (L loc tc_fun) fun_ty args res_ty } -tcApp m_herald fun@(L loc (HsVar _ (L _ fun_id))) args res_ty+tcApp _m_herald (L loc (HsVar _ (L _ fun_id))) args res_ty   -- Special typing rule for tagToEnum#   | fun_id `hasKey` tagToEnumKey   , n_val_args == 1   = tcTagToEnum loc fun_id args res_ty--  -- Special typing rule for 'seq'-  -- In the saturated case, behave as if seq had type-  --    forall a (b::TYPE r). a -> b -> b-  -- for some type r.  See Note [Typing rule for seq]-  | fun_id `hasKey` seqIdKey-  , n_val_args == 2-  = do { rep <- newFlexiTyVarTy runtimeRepTy-       ; let [alpha, beta] = mkTemplateTyVars [liftedTypeKind, tYPE rep]-             seq_ty = mkSpecForAllTys [alpha,beta]-                      (mkTyVarTy alpha `mkFunTy` mkTyVarTy beta `mkFunTy` mkTyVarTy beta)-             seq_fun = L loc (HsVar noExt (L loc seqId))-             -- seq_ty = forall (a:*) (b:TYPE r). a -> b -> b-             -- where 'r' is a meta type variable-        ; tcFunApp m_herald fun seq_fun seq_ty args res_ty }   where     n_val_args = count isHsValArg args -tcApp _ (L loc (ExplicitList _ Nothing [])) [HsTypeArg _ ty_arg] res_ty-  -- See Note [Visible type application for the empty list constructor]-  = do { ty_arg' <- tcHsTypeApp ty_arg liftedTypeKind-       ; let list_ty = TyConApp listTyCon [ty_arg']-       ; _ <- tcSubTypeDS (OccurrenceOf nilDataConName) GenSigCtxt-                          list_ty res_ty-       ; let expr :: LHsExpr GhcTcId-             expr = L loc $ ExplicitList ty_arg' Nothing []-       ; return (idHsWrapper, expr, []) }- tcApp m_herald fun args res_ty   = do { (tc_fun, fun_ty) <- tcInferFun fun        ; tcFunApp m_herald fun tc_fun fun_ty args res_ty }@@ -1238,26 +1188,6 @@ mk_op_msg :: LHsExpr GhcRn -> SDoc mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes" -{--Note [Visible type application for the empty list constructor]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Getting the expression [] @Int to typecheck is slightly tricky since [] isn't-an ordinary data constructor. By default, when tcExpr typechecks a list-expression, it wraps the expression in a coercion, which gives it a type to the-effect of p[a]. It isn't until later zonking that the type becomes-forall a. [a], but that's too late for visible type application.--The workaround is to check for empty list expressions that have a visible type-argument in tcApp, and if so, directly typecheck [] @ty data constructor name.-This avoids the intermediate coercion and produces an expression of type [ty],-as one would intuitively expect.--Unfortunately, this workaround isn't terribly robust, since more involved-expressions such as (let in []) @Int won't work. Until a more elegant fix comes-along, however, this at least allows direct type application on [] to work,-which is better than before.--}- ---------------- tcInferFun :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType) -- Infer type of a function@@ -1274,7 +1204,7 @@ tcInferFun fun   = tcInferSigma fun       -- NB: tcInferSigma; see TcUnify-      -- Note [Deep instantiation of InferResult]+      -- Note [Deep instantiation of InferResult] in TcUnify   ----------------@@ -1288,6 +1218,14 @@        -> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)           -- ^ (a wrapper for the function, the tc'd args, result type) tcArgs fun orig_fun_ty fun_orig orig_args herald+  | fun_is_out_of_scope+  , any isHsTypeArg orig_args+  = failM  -- See Note [VTA for out-of-scope functions]+    -- We have /already/ emitted a CHoleCan constraint (in tcInferFun),+    -- which will later cough up a "Variable not in scope error", so+    -- we can simply fail now, avoiding a confusing error cascade++  | otherwise   = go [] 1 orig_fun_ty orig_args   where     -- Don't count visible type arguments when determining how many arguments@@ -1296,6 +1234,11 @@     -- See Note [Herald for matchExpectedFunTys] in TcUnify.     orig_expr_args_arity = count isHsValArg orig_args +    fun_is_out_of_scope  -- See Note [VTA for out-of-scope functions]+      = case fun of+          L _ (HsUnboundVar {}) -> True+          _                     -> False+     go _ _ fun_ty [] = return (idHsWrapper, [], fun_ty)      go acc_args n fun_ty (HsArgPar sp : args)@@ -1362,7 +1305,7 @@  {- Note [Required quantifiers in the type of a term] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (Trac #15859)+Consider (#15859)    data A k :: k -> Type      -- A      :: forall k -> k -> Type   type KindOf (a :: k) = k   -- KindOf :: forall k. k -> Type@@ -1379,6 +1322,33 @@ The ice is thin; c.f. Note [No Required TyCoBinder in terms] in TyCoRep. +Note [VTA for out-of-scope functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose 'wurble' is not in scope, and we have+   (wurble @Int @Bool True 'x')++Then the renamer will make (HsUnboundVar "wurble) for 'wurble',+and the typechecker will typecheck it with tcUnboundId, giving it+a type 'alpha', and emitting a deferred CHoleCan constraint, to+be reported later.++But then comes the visible type application. If we do nothing, we'll+generate an immediate failure (in tc_app_err), saying that a function+of type 'alpha' can't be applied to Bool.  That's insane!  And indeed+users complain bitterly (#13834, #17150.)++The right error is the CHoleCan, which reports 'wurble' as out of+scope, and tries to give its type.++Fortunately in tcArgs we still have acces to the function, so+we can check if it is a HsUnboundVar.  If so, we simply fail+immediately.  We've already inferred the type of the function,+so we'll /already/ have emitted a CHoleCan constraint; failing+preserves that constraint.++A mild shortcoming of this approach is that we thereby+don't typecheck any of the arguments, but so be it.+ Note [Visible type application zonk] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Substitutions should be kind-preserving, so we need kind(tv) = kind(ty_arg).@@ -1390,7 +1360,7 @@  So we must zonk inner_ty as well, to guarantee consistency between zonk(tv) and inner_ty.  Otherwise we can build an ill-kinded type.  An example was-Trac #14158, where we had:+#14158, where we had:    id :: forall k. forall (cat :: k -> k -> *). forall (a :: k). cat a a and we had the visible type application   id @(->)@@ -1405,7 +1375,7 @@   but we must first zonk the inner_ty to get       forall (a :: TYPE q1). cat a a   so that the result of substitution is well-kinded-  Failing to do so led to Trac #14158.+  Failing to do so led to #14158. -}  ----------------@@ -1425,7 +1395,7 @@     go (L l (Missing {}),   arg_ty) = return (L l (Missing arg_ty))     go (L l (Present x expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty                                            ; return (L l (Present x expr')) }-    go (L _ (XTupArg{}), _) = panic "tcTupArgs"+    go (L _ (XTupArg nec), _) = noExtCon nec  --------------------------- -- See TcType.SyntaxOpType also for commentary@@ -1451,9 +1421,11 @@               -> TcM (a, SyntaxExpr GhcTcId) tcSyntaxOpGen orig op arg_tys res_ty thing_inside   = do { (expr, sigma) <- tcInferSigma $ noLoc $ syn_expr op+       ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma)        ; (result, expr_wrap, arg_wraps, res_wrap)            <- tcSynArgA orig sigma arg_tys res_ty $               thing_inside+       ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma )        ; return (result, SyntaxExpr { syn_expr = mkHsWrap expr_wrap $ unLoc expr                                     , syn_arg_wraps = arg_wraps                                     , syn_res_wrap  = res_wrap }) }@@ -1702,7 +1674,7 @@    e :: _ => IO _     do not apply the MR just like in TcBinds.decideGeneralisationPlan -This makes a difference (Trac #11670):+This makes a difference (#11670):    peek :: Ptr a -> IO CLong    peek ptr = peekElemOff undefined 0 :: _ from (peekElemOff undefined 0) we get@@ -1725,14 +1697,14 @@ tcCheckId name res_ty   = do { (expr, actual_res_ty) <- tcInferId name        ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])-       ; addFunResCtxt False (HsVar noExt (noLoc name)) actual_res_ty res_ty $-         tcWrapResultO (OccurrenceOf name) (HsVar noExt (noLoc name)) expr+       ; addFunResCtxt False (HsVar noExtField (noLoc name)) actual_res_ty res_ty $+         tcWrapResultO (OccurrenceOf name) (HsVar noExtField (noLoc name)) expr                                                           actual_res_ty res_ty }  tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) tcCheckRecSelId rn_expr f@(Unambiguous _ (L _ lbl)) res_ty   = do { (expr, actual_res_ty) <- tcInferRecSelId f-       ; addFunResCtxt False (HsRecFld noExt f) actual_res_ty res_ty $+       ; addFunResCtxt False (HsRecFld noExtField f) actual_res_ty res_ty $          tcWrapResultO (OccurrenceOfRecSel lbl) rn_expr expr actual_res_ty res_ty } tcCheckRecSelId rn_expr (Ambiguous _ lbl) res_ty   = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of@@ -1740,7 +1712,7 @@       Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg                           ; tcCheckRecSelId rn_expr (Unambiguous sel_name lbl)                                                     res_ty }-tcCheckRecSelId _ (XAmbiguousFieldOcc _) _ = panic "tcCheckRecSelId"+tcCheckRecSelId _ (XAmbiguousFieldOcc nec) _ = noExtCon nec  ------------------------ tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcRhoType)@@ -1749,7 +1721,7 @@        ; return (expr', ty) } tcInferRecSelId (Ambiguous _ lbl)   = ambiguousSelector lbl-tcInferRecSelId (XAmbiguousFieldOcc _) = panic "tcInferRecSelId"+tcInferRecSelId (XAmbiguousFieldOcc nec) = noExtCon nec  ------------------------ tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType)@@ -1778,7 +1750,7 @@   = do { assert_error_id <- tcLookupId assertErrorName        ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name)                                           (idType assert_error_id)-       ; return (mkHsWrap wrap (HsVar noExt (noLoc assert_error_id)), id_rho)+       ; return (mkHsWrap wrap (HsVar noExtField (noLoc assert_error_id)), id_rho)        }  tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType)@@ -1804,12 +1776,12 @@              _ -> failWithTc $                   ppr thing <+> text "used where a value identifier was expected" }   where-    return_id id = return (HsVar noExt (noLoc id), idType id)+    return_id id = return (HsVar noExtField (noLoc id), idType id)      return_data_con con        -- For data constructors, must perform the stupid-theta check       | null stupid_theta-      = return (HsConLikeOut noExt (RealDataCon con), con_ty)+      = return (HsConLikeOut noExtField (RealDataCon con), con_ty)        | otherwise        -- See Note [Instantiating stupid theta]@@ -1820,7 +1792,7 @@                  rho'   = substTy subst rho            ; wrap <- instCall (OccurrenceOf id_name) tys' theta'            ; addDataConStupidTheta con tys'-           ; return ( mkHsWrap wrap (HsConLikeOut noExt (RealDataCon con))+           ; return ( mkHsWrap wrap (HsConLikeOut noExtField (RealDataCon con))                     , rho') }        where@@ -1842,14 +1814,14 @@ -- Id; and indeed the evidence for the CHoleCan does bind it, so it's -- not unbound any more! tcUnboundId rn_expr unbound res_ty- = do { ty <- newOpenFlexiTyVarTy  -- Allow Int# etc (Trac #12531)+ = do { ty <- newOpenFlexiTyVarTy  -- Allow Int# etc (#12531)       ; let occ = unboundVarOcc unbound       ; name <- newSysName occ       ; let ev = mkLocalId name ty       ; can <- newHoleCt (ExprHole unbound) ev ty       ; emitInsoluble can-      ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr (HsVar noExt (noLoc ev))-                                                                     ty res_ty }+      ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr+          (HsVar noExtField (noLoc ev)) ty res_ty }   {-@@ -1945,7 +1917,7 @@                  (mk_error ty' doc2)         ; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy)-       ; let fun' = L loc (mkHsWrap (WpTyApp rep_ty) (HsVar noExt (L loc fun)))+       ; let fun' = L loc (mkHsWrap (WpTyApp rep_ty) (HsVar noExtField (L loc fun)))              rep_ty = mkTyConApp rep_tc rep_args              out_args = concat               [ pars1@@ -1974,7 +1946,7 @@   where     pp (HsValArg e)                             = ppr e     pp (HsTypeArg _ (HsWC { hswc_body = L _ t })) = pprHsType t-    pp (HsTypeArg _ (XHsWildCardBndrs _)) = panic "too_many_args"+    pp (HsTypeArg _ (XHsWildCardBndrs nec)) = noExtCon nec     pp (HsArgPar _) = empty  @@ -2034,12 +2006,13 @@         ; lift <- if isStringTy id_ty then                      do { sid <- tcLookupId THNames.liftStringName                                      -- See Note [Lifting strings]-                        ; return (HsVar noExt (noLoc sid)) }+                        ; return (HsVar noExtField (noLoc sid)) }                   else                      setConstraintVar lie_var   $                           -- Put the 'lift' constraint into the right LIE                      newMethodFromName (OccurrenceOf id_name)-                                       THNames.liftName id_ty+                                       THNames.liftName+                                       [getRuntimeRep id_ty, id_ty]                     -- Update the pending splices         ; ps <- readMutVar ps_var@@ -2195,7 +2168,7 @@ omitted. Moreover, this might change the behaviour of typechecker in non-obvious ways. -See also Note [HsRecField and HsRecUpdField] in HsPat.+See also Note [HsRecField and HsRecUpdField] in GHC.Hs.Pat. -}  -- Given a RdrName that refers to multiple record fields, and the type@@ -2449,7 +2422,7 @@            ; return Nothing }   where         field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)-tcRecordField _ _ (L _ (XFieldOcc _)) _ = panic "tcRecordField"+tcRecordField _ _ (L _ (XFieldOcc nec)) _ = noExtCon nec   checkMissingFields ::  ConLike -> HsRecordBinds GhcRn -> TcM ()@@ -2689,7 +2662,7 @@    r { x=e1, y=e2, z=e3 }, we  Finding the smallest subset is hard, so the code here makes-a decent stab, no more.  See Trac #7989.+a decent stab, no more.  See #7989. -}  naughtyRecordSel :: RdrName -> SDoc
compiler/typecheck/TcExpr.hs-boot view
@@ -1,9 +1,10 @@ module TcExpr where import Name-import HsSyn    ( HsExpr, LHsExpr, SyntaxExpr )+import GHC.Hs    ( HsExpr, LHsExpr, SyntaxExpr ) import TcType   ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType )-import TcRnTypes( TcM, CtOrigin )-import HsExtension ( GhcRn, GhcTcId )+import TcRnTypes( TcM )+import TcOrigin ( CtOrigin )+import GHC.Hs.Extension ( GhcRn, GhcTcId )  tcPolyExpr ::           LHsExpr GhcRn@@ -15,11 +16,11 @@        -> ExpRhoType        -> TcM (LHsExpr GhcTcId) -tcInferSigma, tcInferSigmaNC ::+tcInferSigma ::           LHsExpr GhcRn        -> TcM (LHsExpr GhcTcId, TcSigmaType) -tcInferRho ::+tcInferRho, tcInferRhoNC ::           LHsExpr GhcRn        -> TcM (LHsExpr GhcTcId, TcRhoType)
compiler/typecheck/TcFlatten.hs view
@@ -1,17 +1,21 @@-{-# LANGUAGE CPP, ViewPatterns, BangPatterns #-}+{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns, BangPatterns #-}  module TcFlatten(    FlattenMode(..),    flatten, flattenKind, flattenArgsNom,+   rewriteTyVar,     unflattenWanteds  ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import TcRnTypes+import TyCoPpr       ( pprTyVar )+import Constraint+import Predicate import TcType import Type import TcEvidence@@ -29,6 +33,7 @@ import Bag import Control.Monad import MonadUtils    ( zipWith3M )+import Data.Foldable ( foldrM )  import Control.Arrow ( first ) @@ -222,7 +227,7 @@  Note [Unflattening can force the solver to iterate] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Look at Trac #10340:+Look at #10340:    type family Any :: *   -- No instances    get :: MonadState s m => m s    instance MonadState s (State s) where ...@@ -426,7 +431,7 @@ G a ~ Bool.  ---------------------------Trac #9318 has a very simple program leading to+#9318 has a very simple program leading to    [W] F Int ~ Int   [W] F Int ~ Bool@@ -453,7 +458,8 @@  data FlattenEnv   = FE { fe_mode    :: !FlattenMode-       , fe_loc     :: !CtLoc             -- See Note [Flattener CtLoc]+       , fe_loc     :: CtLoc              -- See Note [Flattener CtLoc]+                      -- unbanged because it's bogus in rewriteTyVar        , fe_flavour :: !CtFlavour        , fe_eq_rel  :: !EqRel             -- See Note [Flattener EqRels]        , fe_work    :: !FlatWorkListRef } -- See Note [The flattening work list]@@ -485,15 +491,13 @@ -- See Note [The flattening work list]. newtype FlatM a   = FlatM { runFlatM :: FlattenEnv -> TcS a }+  deriving (Functor)  instance Monad FlatM where   m >>= k  = FlatM $ \env ->              do { a  <- runFlatM m env                 ; runFlatM (k a) env } -instance Functor FlatM where-  fmap = liftM- instance Applicative FlatM where   pure x = FlatM $ const (pure x)   (<*>) = ap@@ -519,7 +523,8 @@ runFlatten mode loc flav eq_rel thing_inside   = do { flat_ref <- newTcRef []        ; let fmode = FE { fe_mode = mode-                        , fe_loc  = loc+                        , fe_loc  = bumpCtLocDepth loc+                            -- See Note [Flatten when discharging CFunEqCan]                         , fe_flavour = flav                         , fe_eq_rel = eq_rel                         , fe_work = flat_ref }@@ -625,7 +630,7 @@    * Processing w3 first is BAD, because we can't reduce i t,so it'll     get put into the inert set, and later kicked out when w1, w2 are-    solved.  In Trac #9872 this led to inert sets containing hundreds+    solved.  In #9872 this led to inert sets containing hundreds     of suspended calls.    * So we want to process w1, w2 first.@@ -742,8 +747,27 @@ *  They are all wrapped in runFlatten, so their                        * *  flattening work gets put into the work list                         * *                                                                      *-********************************************************************* -}+********************************************************************* +Note [rewriteTyVar]+~~~~~~~~~~~~~~~~~~~~~~+Suppose we have an injective function F and+  inert_funeqs:   F t1 ~ fsk1+                  F t2 ~ fsk2+  inert_eqs:      fsk1 ~ [a]+                  a ~ Int+                  fsk2 ~ [Int]++We never rewrite the RHS (cc_fsk) of a CFunEqCan. But we /do/ want to get the+[D] t1 ~ t2 from the injectiveness of F. So we flatten cc_fsk of CFunEqCans+when trying to find derived equalities arising from injectivity.+-}++-- | See Note [Flattening].+-- If (xi, co) <- flatten mode ev ty, then co :: xi ~r ty+-- where r is the role in @ev@. If @mode@ is 'FM_FlattenAll',+-- then 'xi' is almost function-free (Note [Almost function-free]+-- in TcRnTypes). flatten :: FlattenMode -> CtEvidence -> TcType         -> TcS (Xi, TcCoercion) flatten mode ev ty@@ -752,8 +776,27 @@        ; traceTcS "flatten }" (ppr ty')        ; return (ty', co) } +-- Apply the inert set as an *inert generalised substitution* to+-- a variable, zonking along the way.+-- See Note [inert_eqs: the inert equalities] in TcSMonad.+-- Equivalently, this flattens the variable with respect to NomEq+-- in a Derived constraint. (Why Derived? Because Derived allows the+-- most about of rewriting.) Returns no coercion, because we're+-- using Derived constraints.+-- See Note [rewriteTyVar]+rewriteTyVar :: TcTyVar -> TcS TcType+rewriteTyVar tv+  = do { traceTcS "rewriteTyVar {" (ppr tv)+       ; (ty, _) <- runFlatten FM_SubstOnly fake_loc Derived NomEq $+                    flattenTyVar tv+       ; traceTcS "rewriteTyVar }" (ppr ty)+       ; return ty }+  where+    fake_loc = pprPanic "rewriteTyVar used a CtLoc" (ppr tv)+ -- specialized to flattening kinds: never Derived, always Nominal -- See Note [No derived kind equalities]+-- See Note [Flattening] flattenKind :: CtLoc -> CtFlavour -> TcType -> TcS (Xi, TcCoercionN) flattenKind loc flav ty   = do { traceTcS "flattenKind {" (ppr flav <+> ppr ty)@@ -764,6 +807,7 @@        ; traceTcS "flattenKind }" (ppr ty' $$ ppr co) -- co is never a panic        ; return (ty', co) } +-- See Note [Flattening] flattenArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion], TcCoercionN) -- Externally-callable, hence runFlatten -- Flatten a vector of types all at once; in fact they are@@ -810,11 +854,14 @@   * zonks, removing any metavariables, and   * applies the substitution embodied in the inert set +The result of flattening is *almost function-free*. See+Note [Almost function-free] in TcRnTypes.+ Because flattening zonks and the returned coercion ("co" above) is also zonked, it's possible that (co :: xi ~ ty) isn't quite true. So, instead, we can rely on this fact: -  (F1) tcTypeKind(xi) succeeds and returns a fully zonked kind+  (F0) co :: xi ~ zonk(ty)  Note that the left-hand type of co is *always* precisely xi. The right-hand type may or may not be ty, however: if ty has unzonked filled-in metavariables,@@ -894,7 +941,7 @@ Note [flatten_exact_fam_app_fully performance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The refactor of GRefl seems to cause performance trouble for T9872x: the allocation of flatten_exact_fam_app_fully_performance increased. See note [Generalized reflexive coercion] in TyCoRep for more information about GRefl and Trac #15192 for the current state.+The refactor of GRefl seems to cause performance trouble for T9872x: the allocation of flatten_exact_fam_app_fully_performance increased. See note [Generalized reflexive coercion] in TyCoRep for more information about GRefl and #15192 for the current state.  The explicit pattern match in homogenise_result helps with T9872a, b, c. @@ -1114,11 +1161,12 @@ --                   _ -> fmode   = flatten_ty_con_app tc tys -flatten_one (FunTy ty1 ty2)+flatten_one ty@(FunTy _ ty1 ty2)   = do { (xi1,co1) <- flatten_one ty1        ; (xi2,co2) <- flatten_one ty2        ; role <- getRole-       ; return (mkFunTy xi1 xi2, mkFunCo role co1 co2) }+       ; return (ty { ft_arg = xi1, ft_res = xi2 }+                , mkFunCo role co1 co2) }  flatten_one ty@(ForAllTy {}) -- TODO (RAE): This is inadequate, as it doesn't flatten the kind of@@ -1268,7 +1316,7 @@ synonym.  This works because TcTyConAppCo can deal with synonyms (unlike TyConAppCo), see Note [TcCoercions] in TcEvidence. -But (Trac #8979) for+But (#8979) for    type T a = (F a, a)    where F is a type function we must expand the synonym in (say) T Int, to expose the type function to the flattener.@@ -1329,8 +1377,7 @@   -- See Note [Reduce type family applications eagerly]      -- the following tcTypeKind should never be evaluated, as it's just used in      -- casting, and casts by refl are dropped-  = do { let reduce_co = mkNomReflCo (tcTypeKind (mkTyConApp tc tys))-       ; mOut <- try_to_reduce_nocache tc tys reduce_co id+  = do { mOut <- try_to_reduce_nocache tc tys        ; case mOut of            Just out -> pure out            Nothing -> do@@ -1363,7 +1410,7 @@                            ; let xi  = fsk_xi `mkCastTy` kind_co                                  co' = mkTcCoherenceLeftCo role fsk_xi kind_co fsk_co                                        `mkTransCo`-                                       maybeSubCo eq_rel (mkSymCo co)+                                       maybeTcSubCo eq_rel (mkSymCo co)                                        `mkTransCo` ret_co                            ; return (xi, co')                            }@@ -1398,7 +1445,7 @@                                  --     the xis are flattened                                  ; let fsk_ty = mkTyVarTy fsk                                        xi = fsk_ty `mkCastTy` kind_co-                                       co' = mkTcCoherenceLeftCo role fsk_ty kind_co (maybeSubCo eq_rel (mkSymCo co))+                                       co' = mkTcCoherenceLeftCo role fsk_ty kind_co (maybeTcSubCo eq_rel (mkSymCo co))                                              `mkTransCo` ret_co                                  ; return (xi, co')                                  }@@ -1436,7 +1483,7 @@                               ]                        ; (xi, final_co) <- bumpDepth $ flatten_one norm_ty                        ; eq_rel <- getEqRel-                       ; let co = maybeSubCo eq_rel norm_co+                       ; let co = maybeTcSubCo eq_rel norm_co                                    `mkTransCo` mkSymCo final_co                        ; flavour <- getFlavour                            -- NB: only extend cache with nominal equalities@@ -1452,16 +1499,8 @@      try_to_reduce_nocache :: TyCon   -- F, family tycon                           -> [Type]  -- args, not necessarily flattened-                          -> CoercionN -- kind_co :: tcTypeKind(F args)-                                       --            ~N tcTypeKind(F orig_args)-                                       -- where-                                       -- orig_args is what was passed to the-                                       -- outer function-                          -> (   Coercion     -- :: (xi |> kind_co) ~ F args-                              -> Coercion )   -- what to return from outer-                                              -- function                           -> FlatM (Maybe (Xi, Coercion))-    try_to_reduce_nocache tc tys kind_co update_co+    try_to_reduce_nocache tc tys       = do { checkStackDepth (mkTyConApp tc tys)            ; mb_match <- liftTcS $ matchFam tc tys            ; case mb_match of@@ -1470,13 +1509,9 @@                Just (norm_co, norm_ty)                  -> do { (xi, final_co) <- bumpDepth $ flatten_one norm_ty                        ; eq_rel <- getEqRel-                       ; let co  = maybeSubCo eq_rel norm_co-                                    `mkTransCo` mkSymCo final_co-                             role = eqRelRole eq_rel-                             xi' = xi `mkCastTy` kind_co-                             co' = update_co $-                                   mkTcCoherenceLeftCo role xi kind_co (mkSymCo co)-                       ; return $ Just (xi', co') }+                       ; let co  = mkSymCo (maybeTcSubCo eq_rel norm_co+                                            `mkTransCo` mkSymCo final_co)+                       ; return $ Just (xi, co) }                Nothing -> pure Nothing }  {- Note [Reduce type family applications eagerly]@@ -1546,7 +1581,7 @@                    ; return (ty2, co2 `mkTransCo` co1) }             FTRNotFollowed   -- Done, but make sure the kind is zonked-                            -- Note [Flattening] invariant (F1)+                            -- Note [Flattening] invariant (F0) and (F1)              -> do { tv' <- liftTcS $ updateTyVarKindM zonkTcType tv                    ; role <- getRole                    ; let ty' = mkTyVarTy tv'@@ -1566,7 +1601,7 @@                              (ppr tv <+> equals <+> ppr ty)                          ; role <- getRole                          ; return (FTRFollowed ty (mkReflCo role ty)) } ;-           Nothing -> do { traceFlat "Unfilled tyvar" (ppr tv)+           Nothing -> do { traceFlat "Unfilled tyvar" (pprTyVar tv)                          ; fr <- getFlavourRole                          ; flatten_tyvar2 tv fr } } @@ -1586,7 +1621,7 @@                         , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct              , let ct_fr = (ctEvFlavour ctev, ct_eq_rel)              , ct_fr `eqCanRewriteFR` fr  -- This is THE key call of eqCanRewriteFR-             ->  do { traceFlat "Following inert tyvar"+             -> do { traceFlat "Following inert tyvar"                         (ppr mode <+>                          ppr tv <+>                          equals <+>@@ -1629,7 +1664,7 @@         (b) the inert cannot rewrite the work item  This is significantly harder to think about. It can save a LOT of work-in occurs-check cases, but we don't care about them much.  Trac #5837+in occurs-check cases, but we don't care about them much.  #5837 is an example; all the constraints here are Givens               [G] a ~ TF (a,Int)@@ -1704,11 +1739,11 @@          --                 ==> (flatten) [W] F alpha ~ fmv, [W] alpha ~ [fmv]          --                 ==> (unify)   [W] F [fmv] ~ fmv          -- See Note [Unflatten using funeqs first]-      ; funeqs <- foldrBagM unflatten_funeq emptyCts funeqs+      ; funeqs <- foldrM unflatten_funeq emptyCts funeqs       ; traceTcS "Unflattening 1" $ braces (pprCts funeqs)            -- Step 2: unify the tv_eqs, if possible-      ; tv_eqs  <- foldrBagM (unflatten_eq tclvl) emptyCts tv_eqs+      ; tv_eqs  <- foldrM (unflatten_eq tclvl) emptyCts tv_eqs       ; traceTcS "Unflattening 2" $ braces (pprCts tv_eqs)            -- Step 3: fill any remaining fmvs with fresh unification variables@@ -1716,7 +1751,7 @@       ; traceTcS "Unflattening 3" $ braces (pprCts funeqs)            -- Step 4: remove any tv_eqs that look like ty ~ ty-      ; tv_eqs <- foldrBagM finalise_eq emptyCts tv_eqs+      ; tv_eqs <- foldrM finalise_eq emptyCts tv_eqs        ; let all_flat = tv_eqs `andCts` funeqs       ; traceTcS "Unflattening done" $ braces (pprCts all_flat)@@ -1872,8 +1907,9 @@   split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty'   split _       (ForAllTy b res) = let (bs, ty, _) = split res res                                    in  (Named b : bs, ty, True)-  split _       (FunTy arg res)  = let (bs, ty, named) = split res res-                                   in  (Anon arg : bs, ty, named)+  split _       (FunTy { ft_af = af, ft_arg = arg, ft_res = res })+                                 = let (bs, ty, named) = split res res+                                   in  (Anon af arg : bs, ty, named)   split orig_ty _                = ([], orig_ty, False) {-# INLINE split_pi_tys' #-} @@ -1884,7 +1920,7 @@   where     go (Bndr tv (NamedTCB vis)) (bndrs, _)       = (Named (Bndr tv vis) : bndrs, True)-    go (Bndr tv AnonTCB)        (bndrs, n)-      = (Anon (tyVarKind tv)   : bndrs, n)+    go (Bndr tv (AnonTCB af))   (bndrs, n)+      = (Anon af (tyVarKind tv)   : bndrs, n)     {-# INLINE go #-} {-# INLINE ty_con_binders_ty_binders' #-}
compiler/typecheck/TcForeign.hs view
@@ -31,11 +31,11 @@         , tcCheckFEType         ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude -import HsSyn+import GHC.Hs  import TcRnMonad import TcHsType@@ -57,14 +57,13 @@ import PrelNames import DynFlags import Outputable-import Platform+import GHC.Platform import SrcLoc import Bag import Hooks import qualified GHC.LanguageExtensions as LangExt  import Control.Monad-import Data.Maybe  -- Defines a binding isForeignImport :: LForeignDecl name -> Bool@@ -206,7 +205,7 @@ want to report it as "defined but not used" or "imported but not used". eg     newtype D = MkD Int        foreign import foo :: D -> IO ()-Here 'MkD' us used.  See Trac #7408.+Here 'MkD' us used.  See #7408.  GHC also expands type functions during this process, so it's not enough just to look at the free variables of the declaration.@@ -251,8 +250,7 @@        ; let            -- Drop the foralls before inspecting the            -- structure of the foreign type.-             (bndrs, res_ty)   = tcSplitPiTys norm_sig_ty-             arg_tys           = mapMaybe binderRelevantType_maybe bndrs+             (arg_tys, res_ty) = tcSplitFunTys (dropForAlls norm_sig_ty)              id                = mkLocalId nm sig_ty                  -- Use a LocalId to obey the invariant that locally-defined                  -- things are LocalIds.  However, it does not need zonking,@@ -277,7 +275,7 @@   = do checkCg checkCOrAsmOrLlvmOrInterp        -- NB check res_ty not sig_ty!        --    In case sig_ty is (forall a. ForeignPtr a)-       check (isFFILabelTy (mkFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty)+       check (isFFILabelTy (mkVisFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty)        cconv' <- checkCConv cconv        return (CImport (L lc cconv') safety mh l src) @@ -307,7 +305,7 @@           addErrTc (illegalForeignTyErr Outputable.empty (text "At least one argument expected"))         (arg1_ty:arg_tys) -> do           dflags <- getDynFlags-          let curried_res_ty = mkFunTys arg_tys res_ty+          let curried_res_ty = mkVisFunTys arg_tys res_ty           check (isFFIDynTy curried_res_ty arg1_ty)                 (illegalForeignTyErr argument)           checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys@@ -424,10 +422,9 @@     checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty     return (CExport (L l (CExportStatic esrc str cconv')) src)   where-      -- Drop the foralls before inspecting n+      -- Drop the foralls before inspecting       -- the structure of the foreign type.-    (bndrs, res_ty) = tcSplitPiTys sig_ty-    arg_tys         = mapMaybe binderRelevantType_maybe bndrs+    (arg_tys, res_ty) = tcSplitFunTys (dropForAlls sig_ty)  {- ************************************************************************@@ -457,6 +454,11 @@   | Just (_, res_ty) <- tcSplitIOType_maybe ty   =     -- Got an IO result type, that's always fine!      check (pred_res_ty res_ty) (illegalForeignTyErr result)++  -- We disallow nested foralls in foreign types+  -- (at least, for the time being). See #16702.+  | tcIsForAllTy ty+  = addErrTc $ illegalForeignTyErr result (text "Unexpected nested forall")    -- Case for non-IO result type with FFI Import   | not non_io_result_ok
compiler/typecheck/TcGenDeriv.hs view
@@ -35,12 +35,12 @@         mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import TcRnMonad-import HsSyn+import GHC.Hs import RdrName import BasicTypes import DataCon@@ -54,8 +54,6 @@ import FamInstEnv import PrelNames import THNames-import Module ( moduleName, moduleNameString-              , moduleUnitId, unitIdString ) import MkId ( coerceId ) import PrimOp import SrcLoc@@ -217,7 +215,7 @@         nested_eq_expr tys as bs           = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)           -- Using 'foldr1' here ensures that the derived code is correctly-          -- associated. See Trac #10859.+          -- associated. See #10859.           where             nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b)) @@ -278,7 +276,7 @@ Note [Game plan for deriving Ord] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's a bad idea to define only 'compare', and build the other binary-comparisons on top of it; see Trac #2130, #4019.  Reason: we don't+comparisons on top of it; see #2130, #4019.  Reason: we don't want to laboriously make a three-way comparison, only to extract a binary result, something like this:      (>) (I# x) (I# y) = case <# x y of@@ -360,11 +358,11 @@       = emptyBag      negate_expr = nlHsApp (nlHsVar not_RDR)-    lE = mk_easy_FunBind loc le_RDR [a_Pat, b_Pat] $+    lE = mkSimpleGeneratedFunBind loc le_RDR [a_Pat, b_Pat] $         negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr)-    gT = mk_easy_FunBind loc gt_RDR [a_Pat, b_Pat] $+    gT = mkSimpleGeneratedFunBind loc gt_RDR [a_Pat, b_Pat] $         nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr-    gE = mk_easy_FunBind loc ge_RDR [a_Pat, b_Pat] $+    gE = mkSimpleGeneratedFunBind loc ge_RDR [a_Pat, b_Pat] $         negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr)      get_tag con = dataConTag con - fIRST_TAG@@ -383,7 +381,7 @@      mkOrdOp :: DynFlags -> OrdOp -> LHsBind GhcPs     -- Returns a binding   op a b = ... compares a and b according to op ....-    mkOrdOp dflags op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat]+    mkOrdOp dflags op = mkSimpleGeneratedFunBind loc (ordMethRdr op) [a_Pat, b_Pat]                                         (mkOrdOpRhs dflags op)      mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr GhcPs@@ -450,7 +448,7 @@                                  , mkHsCaseAlt nlWildPat (gtResult op) ]       where         tag     = get_tag data_con-        tag_lit = noLoc (HsLit noExt (HsIntPrim NoSourceText (toInteger tag)))+        tag_lit = noLoc (HsLit noExtField (HsIntPrim NoSourceText (toInteger tag)))      mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)     -- First argument 'a' known to be built with K@@ -599,7 +597,7 @@     occ_nm = getOccString tycon      succ_enum dflags-      = mk_easy_FunBind loc succ_RDR [a_Pat] $+      = mkSimpleGeneratedFunBind loc succ_RDR [a_Pat] $         untag_Expr dflags tycon [(a_RDR, ah_RDR)] $         nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon),                                nlHsVarApps intDataCon_RDR [ah_RDR]])@@ -609,7 +607,7 @@                                         nlHsIntLit 1]))      pred_enum dflags-      = mk_easy_FunBind loc pred_RDR [a_Pat] $+      = mkSimpleGeneratedFunBind loc pred_RDR [a_Pat] $         untag_Expr dflags tycon [(a_RDR, ah_RDR)] $         nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,                                nlHsVarApps intDataCon_RDR [ah_RDR]])@@ -617,11 +615,11 @@              (nlHsApp (nlHsVar (tag2con_RDR dflags tycon))                       (nlHsApps plus_RDR                             [ nlHsVarApps intDataCon_RDR [ah_RDR]-                            , nlHsLit (HsInt noExt+                            , nlHsLit (HsInt noExtField                                                 (mkIntegralLit (-1 :: Int)))]))      to_enum dflags-      = mk_easy_FunBind loc toEnum_RDR [a_Pat] $+      = mkSimpleGeneratedFunBind loc toEnum_RDR [a_Pat] $         nlHsIf (nlHsApps and_RDR                 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],                  nlHsApps le_RDR [ nlHsVar a_RDR@@ -630,7 +628,7 @@              (illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon))      enum_from dflags-      = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $+      = mkSimpleGeneratedFunBind loc enumFrom_RDR [a_Pat] $           untag_Expr dflags tycon [(a_RDR, ah_RDR)] $           nlHsApps map_RDR                 [nlHsVar (tag2con_RDR dflags tycon),@@ -639,7 +637,7 @@                             (nlHsVar (maxtag_RDR dflags tycon)))]      enum_from_then dflags-      = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $+      = mkSimpleGeneratedFunBind loc enumFromThen_RDR [a_Pat, b_Pat] $           untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $             nlHsPar (enum_from_then_to_Expr@@ -652,7 +650,7 @@                            ))      from_enum dflags-      = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $+      = mkSimpleGeneratedFunBind loc fromEnum_RDR [a_Pat] $           untag_Expr dflags tycon [(a_RDR, ah_RDR)] $           (nlHsVarApps intDataCon_RDR [ah_RDR]) @@ -687,9 +685,9 @@     arity          = dataConSourceArity data_con_1      min_bound_1con = mkHsVarBind loc minBound_RDR $-                     nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)+                     nlHsVarApps data_con_1_RDR (replicate arity minBound_RDR)     max_bound_1con = mkHsVarBind loc maxBound_RDR $-                     nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)+                     nlHsVarApps data_con_1_RDR (replicate arity maxBound_RDR)  {- ************************************************************************@@ -768,7 +766,7 @@       ]      enum_range dflags-      = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $+      = mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $           untag_Expr dflags tycon [(a_RDR, ah_RDR)] $           untag_Expr dflags tycon [(b_RDR, bh_RDR)] $           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $@@ -777,8 +775,8 @@                         (nlHsVarApps intDataCon_RDR [bh_RDR]))      enum_index dflags-      = mk_easy_FunBind loc unsafeIndex_RDR-                [noLoc (AsPat noExt (noLoc c_RDR)+      = mkSimpleGeneratedFunBind loc unsafeIndex_RDR+                [noLoc (AsPat noExtField (noLoc c_RDR)                            (nlTuplePat [a_Pat, nlWildPat] Boxed)),                                 d_Pat] (            untag_Expr dflags tycon [(a_RDR, ah_RDR)] (@@ -794,7 +792,7 @@      -- This produces something like `(ch >= ah) && (ch <= bh)`     enum_inRange dflags-      = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $+      = mkSimpleGeneratedFunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $           untag_Expr dflags tycon [(a_RDR, ah_RDR)] (           untag_Expr dflags tycon [(b_RDR, bh_RDR)] (           untag_Expr dflags tycon [(c_RDR, ch_RDR)] (@@ -827,7 +825,7 @@      --------------------------------------------------------------     single_con_range-      = mk_easy_FunBind loc range_RDR+      = mkSimpleGeneratedFunBind loc range_RDR           [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $         noLoc (mkHsComp ListComp stmts con_expr)       where@@ -839,7 +837,7 @@      ----------------     single_con_index-      = mk_easy_FunBind loc unsafeIndex_RDR+      = mkSimpleGeneratedFunBind loc unsafeIndex_RDR                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,                  con_pat cs_needed]         -- We need to reverse the order we consider the components in@@ -865,12 +863,12 @@      ------------------     single_con_inRange-      = mk_easy_FunBind loc inRange_RDR+      = mkSimpleGeneratedFunBind loc inRange_RDR                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,                  con_pat cs_needed] $           if con_arity == 0              -- If the product type has no fields, inRange is trivially true-             -- (see Trac #12853).+             -- (see #12853).              then true_Expr              else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range                     as_needed bs_needed cs_needed)@@ -927,12 +925,12 @@    Ident "T1" <- lexP The latter desugares to inline code for matching the Ident and the string, and this can be very voluminous. The former is much more-compact.  Cf Trac #7258, although that also concerned non-linearity in+compact.  Cf #7258, although that also concerned non-linearity in the occurrence analyser, a separate issue.  Note [Read for empty data types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-What should we get for this?  (Trac #7931)+What should we get for this?  (#7931)    data Emp deriving( Read )   -- No data constructors  Here we want@@ -1060,7 +1058,7 @@      -- For constructors and field labels ending in '#', we hackily     -- let the lexer generate two tokens, and look for both in sequence-    -- Thus [Ident "I"; Symbol "#"].  See Trac #5041+    -- Thus [Ident "I"; Symbol "#"].  See #5041     ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]                   | otherwise                    = [ ident_pat s ] @@ -1150,7 +1148,7 @@       | otherwise   =          ([a_Pat, con_pat],           showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit-                         (HsInt noExt (mkIntegralLit con_prec_plus_one))))+                         (HsInt noExtField (mkIntegralLit con_prec_plus_one))))                          (nlHsPar (nested_compose_Expr show_thingies)))         where              data_con_RDR  = getRdrName data_con@@ -1243,7 +1241,7 @@ -- | showsPrec :: Show a => Int -> a -> ShowS mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs mk_showsPrec_app p x-  = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExt (mkIntegralLit p)), x]+  = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExtField (mkIntegralLit p)), x]  -- | shows :: Show a => a -> ShowS mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs@@ -1313,7 +1311,7 @@         -- Make unique names for the data type and constructor        -- auxiliary bindings.  Start with the name of the TyCon/DataCon-       -- but that might not be unique: see Trac #12245.+       -- but that might not be unique: see #12245.        ; dt_occ  <- chooseUniqueOccTc (mkDataTOcc (getOccName rep_tc))        ; dc_occs <- mapM (chooseUniqueOccTc . mkDataCOcc . getOccName)                          (tyConDataCons rep_tc)@@ -1340,7 +1338,7 @@     genDataTyCon :: DerivStuff     genDataTyCon        --  $dT       = DerivHsBind (mkHsVarBind loc data_type_name rhs,-                     L loc (TypeSig noExt [L loc data_type_name] sig_ty))+                     L loc (TypeSig noExtField [L loc data_type_name] sig_ty))      sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)     rhs    = nlHsVar mkDataType_RDR@@ -1350,7 +1348,7 @@     genDataDataCon :: DataCon -> RdrName -> DerivStuff     genDataDataCon dc constr_name       --  $cT1 etc       = DerivHsBind (mkHsVarBind loc constr_name rhs,-                     L loc (TypeSig noExt [L loc constr_name] sig_ty))+                     L loc (TypeSig noExtField [L loc constr_name] sig_ty))       where         sig_ty   = mkLHsSigWcType (nlHsTyVar constr_RDR)         rhs      = nlHsApps mkConstr_RDR constr_args@@ -1382,7 +1380,7 @@                      mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))          ------------ gunfold-    gunfold_bind = mk_easy_FunBind loc+    gunfold_bind = mkSimpleGeneratedFunBind loc                      gunfold_RDR                      [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat]                      gunfold_rhs@@ -1411,7 +1409,7 @@     to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name)          ------------ dataTypeOf-    dataTypeOf_bind = mk_easy_FunBind+    dataTypeOf_bind = mkSimpleGeneratedFunBind                         loc                         dataTypeOf_RDR                         [nlWildPat]@@ -1430,7 +1428,7 @@         -- because D :: * -> *         -- even though rep_tc has kind * -> * -> * -> *         -- Hence looking for the kind of fam_tc not rep_tc-        -- See Trac #4896+        -- See #4896     tycon_kind = case tyConFamInst_maybe rep_tc of                     Just (fam_tc, _) -> tyConKind fam_tc                     Nothing          -> tyConKind rep_tc@@ -1438,13 +1436,13 @@                 | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR                 | otherwise                 = emptyBag     mk_gcast dataCast_RDR gcast_RDR-      = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]+      = unitBag (mkSimpleGeneratedFunBind loc dataCast_RDR [nlVarPat f_RDR]                                  (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))   kind1, kind2 :: Kind-kind1 = liftedTypeKind `mkFunTy` liftedTypeKind-kind2 = liftedTypeKind `mkFunTy` kind1+kind1 = typeToTypeKind+kind2 = liftedTypeKind `mkVisFunTy` kind1  gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,     mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,@@ -1559,68 +1557,36 @@     ==>      instance (Lift a) => Lift (Foo a) where-        lift (Foo a)-          = appE-              (conE-                (mkNameG_d "package-name" "ModuleName" "Foo"))-              (lift a)-        lift (u :^: v)-          = infixApp-              (lift u)-              (conE-                (mkNameG_d "package-name" "ModuleName" ":^:"))-              (lift v)+        lift (Foo a) = [| Foo a |]+        lift ((:^:) u v) = [| (:^:) u v |] -Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what-'Foo would be when using the -XTemplateHaskell extension. To make sure that--XDeriveLift can be used on stage-1 compilers, however, we explicitly invoke-makeG_d.+        liftTyped (Foo a) = [|| Foo a ||]+        liftTyped ((:^:) u v) = [|| (:^:) u v ||] -} + gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)-gen_Lift_binds loc tycon = (unitBag lift_bind, emptyBag)+gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag)   where-    lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)-                            (map pats_etc data_cons)+    lift_bind      = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)+                                 (map (pats_etc mk_exp) data_cons)+    liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp pure_Expr)+                                 (map (pats_etc mk_texp) data_cons)++    mk_exp = ExpBr noExtField+    mk_texp = TExpBr noExtField     data_cons = tyConDataCons tycon -    pats_etc data_con+    pats_etc mk_bracket data_con       = ([con_pat], lift_Expr)        where             con_pat      = nlConVarPat data_con_RDR as_needed             data_con_RDR = getRdrName data_con             con_arity    = dataConSourceArity data_con             as_needed    = take con_arity as_RDRs-            lifted_as    = zipWithEqual "mk_lift_app" mk_lift_app-                             tys_needed as_needed-            tycon_name   = tyConName tycon-            is_infix     = dataConIsInfix data_con-            tys_needed   = dataConOrigArgTys data_con--            mk_lift_app ty a-              | not (isUnliftedType ty) = nlHsApp (nlHsVar lift_RDR)-                                                  (nlHsVar a)-              | otherwise = nlHsApp (nlHsVar litE_RDR)-                              (primLitOp (mkBoxExp (nlHsVar a)))-              where (primLitOp, mkBoxExp) = primLitOps "Lift" ty--            pkg_name = unitIdString . moduleUnitId-                     . nameModule $ tycon_name-            mod_name = moduleNameString . moduleName . nameModule $ tycon_name-            con_name = occNameString . nameOccName . dataConName $ data_con--            conE_Expr = nlHsApp (nlHsVar conE_RDR)-                                (nlHsApps mkNameG_dRDR-                                  (map (nlHsLit . mkHsString)-                                    [pkg_name, mod_name, con_name]))--            lift_Expr-              | is_infix  = nlHsApps infixApp_RDR [a1, conE_Expr, a2]-              | otherwise = foldl' mk_appE_app conE_Expr lifted_as-            (a1:a2:_) = lifted_as--mk_appE_app :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs-mk_appE_app a b = nlHsApps appE_RDR [a, b]+            lift_Expr    = noLoc (HsBracket noExtField (mk_bracket br_body))+            br_body      = nlHsApps (Exact (dataConName data_con))+                                    (map nlHsVar as_needed)  {- ************************************************************************@@ -1684,7 +1650,7 @@  Note [Newtype-deriving trickiness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (Trac #12768):+Consider (#12768):   class C a where { op :: D a => a -> a }    instance C a  => C [a] where { op = opList }@@ -1895,12 +1861,12 @@     underlying_inst_tys = changeLast inst_tys rhs_ty  nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs-nlHsAppType e s = noLoc (HsAppType noExt e hs_ty)+nlHsAppType e s = noLoc (HsAppType noExtField e hs_ty)   where     hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec (typeToLHsType s)  nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs-nlExprWithTySig e s = noLoc $ ExprWithTySig noExt (parenthesizeHsExpr sigPrec e) hs_ty+nlExprWithTySig e s = noLoc $ ExprWithTySig noExtField (parenthesizeHsExpr sigPrec e) hs_ty   where     hs_ty = mkLHsSigWcType (typeToLHsType s) @@ -1950,13 +1916,13 @@                   -> (LHsBind GhcPs, LSig GhcPs) genAuxBindSpec dflags loc (DerivCon2Tag tycon)   = (mkFunBindSE 0 loc rdr_name eqns,-     L loc (TypeSig noExt [L loc rdr_name] sig_ty))+     L loc (TypeSig noExtField [L loc rdr_name] sig_ty))   where     rdr_name = con2tag_RDR dflags tycon      sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $              mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $-             mkParentType tycon `mkFunTy` intPrimTy+             mkParentType tycon `mkVisFunTy` intPrimTy      lots_of_constructors = tyConFamilySize tycon > 8                         -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS@@ -1976,17 +1942,17 @@   = (mkFunBindSE 0 loc rdr_name         [([nlConVarPat intDataCon_RDR [a_RDR]],            nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],-     L loc (TypeSig noExt [L loc rdr_name] sig_ty))+     L loc (TypeSig noExtField [L loc rdr_name] sig_ty))   where     sig_ty = mkLHsSigWcType $ L loc $              XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $-             intTy `mkFunTy` mkParentType tycon+             intTy `mkVisFunTy` mkParentType tycon      rdr_name = tag2con_RDR dflags tycon  genAuxBindSpec dflags loc (DerivMaxTag tycon)   = (mkHsVarBind loc rdr_name rhs,-     L loc (TypeSig noExt [L loc rdr_name] sig_ty))+     L loc (TypeSig noExtField [L loc rdr_name] sig_ty))   where     rdr_name = maxtag_RDR dflags tycon     sig_ty = mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy)))@@ -2007,11 +1973,11 @@   splitDerivAuxBind (DerivAuxBind x) = Left x   splitDerivAuxBind  x               = Right x -  rm_dups = foldrBag dup_check emptyBag+  rm_dups = foldr dup_check emptyBag   dup_check a b = if anyBag (== a) b then b else consBag a b    genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff-  genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1)+  genAuxBinds' = foldr f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1)                             , emptyBag )   f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff   f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before@@ -2053,7 +2019,7 @@ mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]              -> LHsBind GhcPs mkRdrFunBind fun@(L loc _fun_rdr) matches-  = L loc (mkFunBind fun matches)+  = L loc (mkFunBind Generated fun matches)  -- | Make a function binding. If no equations are given, produce a function -- with the given arity that uses an empty case expression for the last@@ -2081,7 +2047,7 @@                -> [LMatch GhcPs (LHsExpr GhcPs)]                -> LHsBind GhcPs mkRdrFunBindEC arity catch_all-                 fun@(L loc _fun_rdr) matches = L loc (mkFunBind fun matches')+                 fun@(L loc _fun_rdr) matches = L loc (mkFunBind Generated fun matches')  where    -- Catch-all eqn looks like    --     fmap _ z = case z of {}@@ -2091,7 +2057,7 @@    --     foldMap _ z = mempty    -- It's needed if there no data cons at all,    -- which can happen with -XEmptyDataDecls-   -- See Trac #4302+   -- See #4302    matches' = if null matches               then [mkMatch (mkPrefixFunRhs fun)                             (replicate (arity - 1) nlWildPat ++ [z_Pat])@@ -2105,13 +2071,13 @@ mkRdrFunBindSE :: Arity -> Located RdrName ->                     [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBindSE arity-                 fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')+                 fun@(L loc fun_rdr) matches = L loc (mkFunBind Generated fun matches')  where    -- Catch-all eqn looks like    --     compare _ _ = error "Void compare"    -- It's needed if there no data cons at all,    -- which can happen with -XEmptyDataDecls-   -- See Trac #4302+   -- See #4302    matches' = if null matches               then [mkMatch (mkPrefixFunRhs fun)                             (replicate arity nlWildPat)@@ -2134,17 +2100,6 @@ -- See Note [Deriving and unboxed types] in TcDerivInfer primOrdOps str ty = assoc_ty_id str ordOpTbl ty -primLitOps :: String -- The class involved-           -> Type   -- The type-           -> ( LHsExpr GhcPs -> LHsExpr GhcPs -- Constructs a Q Exp value-              , LHsExpr GhcPs -> LHsExpr GhcPs -- Constructs a boxed value-              )-primLitOps str ty = (assoc_ty_id str litConTbl ty, \v -> boxed v)-  where-    boxed v-      | ty `eqType` addrPrimTy = nlHsVar unpackCString_RDR `nlHsApp` v-      | otherwise = assoc_ty_id str boxConTbl ty v- ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))] ordOpTbl  =  [(charPrimTy  , (ltChar_RDR  , leChar_RDR@@ -2425,7 +2380,7 @@ Of course these top-level bindings should all have distinct name, and we are generating RdrNames here.  We can't just use the TyCon or DataCon to distinguish because with standalone deriving two imported TyCons might both be called T!-(See Trac #7947.)+(See #7947.)  So we use package name, module name and the name of the parent (T in this example) as part of the OccName we generate for the new binding.
compiler/typecheck/TcGenFunctor.hs view
@@ -23,7 +23,7 @@ import Bag import DataCon import FastString-import HsSyn+import GHC.Hs import Panic import PrelNames import RdrName@@ -369,10 +369,11 @@      go co ty | Just ty' <- tcView ty = go co ty'     go co (TyVarTy    v) | v == var = (if co then caseCoVar else caseVar,True)-    go co (FunTy x y)  | isPredTy x = go co y-                       | xc || yc   = (caseFun xr yr,True)-        where (xr,xc) = go (not co) x-              (yr,yc) = go co       y+    go co (FunTy { ft_arg = x, ft_res = y, ft_af = af })+       | InvisArg <- af = go co y+       | xc || yc       = (caseFun xr yr,True)+       where (xr,xc) = go (not co) x+             (yr,yc) = go co       y     go co (AppTy    x y) | xc = (caseWrongArg,   True)                          | yc = (caseTyApp x yr, True)         where (_, xc) = go co x@@ -390,7 +391,7 @@          -- When folding over an unboxed tuple, we must explicitly drop the          -- runtime rep arguments, or else GHC will generate twice as many          -- variables in a unboxed tuple pattern match and expression as it-         -- actually needs. See Trac #12399+         -- actually needs. See #12399          (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args))     go co (ForAllTy (Bndr v vis) x)        | isVisibleArgFlag vis = panic "unexpected visible binder"@@ -1050,8 +1051,8 @@ that is syntactically equivalent to the last type parameter, so only E1's argument will be folded over in a derived Foldable instance. -See Trac #10447 for the original discussion on this feature. Also see-https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor+See #10447 for the original discussion on this feature. Also see+https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/derive-functor for a more in-depth explanation.  Note [FFoldType and functorLikeTraverse]@@ -1153,7 +1154,7 @@ 1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure    expects an argument whose type is of kind *. This effectively prevents    Traversable from being derived for any datatype with an unlifted argument-   type (Trac #11174).+   type (#11174).  2. The generated code contains superfluous expressions. By the Monoid laws,    we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can
compiler/typecheck/TcGenGenerics.hs view
@@ -16,7 +16,7 @@  import GhcPrelude -import HsSyn+import GHC.Hs import Type import TcType import TcGenDeriv@@ -50,7 +50,7 @@ import Data.List (zip4, partition) import Data.Maybe (isJust) -#include "GhclibHsVersions.h"+#include "HsVersions.h"  {- ************************************************************************@@ -431,7 +431,7 @@            env        = zipTyEnv env_tyvars env_inst_args            in_scope   = mkInScopeSet (tyCoVarsOfTypes inst_tys)            subst      = mkTvSubst in_scope env-           repTy'     = substTy  subst repTy+           repTy'     = substTyUnchecked  subst repTy            tcv'       = tyCoVarsOfTypeList inst_ty            (tv', cv') = partition isTyVar tcv'            tvs'       = scopedSort tv'@@ -577,17 +577,15 @@         mkS mlbl su ss ib a = mkTyConApp s1 [k, metaSelTy mlbl su ss ib, a]          -- Sums and products are done in the same way for both Rep and Rep1-        sumP [] = mkTyConApp v1 [k]-        sumP l  = foldBal mkSum' . map mkC  $ l+        sumP l = foldBal mkSum' (mkTyConApp v1 [k]) . map mkC $ l         -- The Bool is True if this constructor has labelled fields         prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type-        prod [] _  _  _  = mkTyConApp u1 [k]-        prod l  sb ib fl = foldBal mkProd-                                   [ ASSERT(null fl || lengthExceeds fl j)-                                     arg t sb' ib' (if null fl-                                                       then Nothing-                                                       else Just (fl !! j))-                                   | (t,sb',ib',j) <- zip4 l sb ib [0..] ]+        prod l sb ib fl = foldBal mkProd (mkTyConApp u1 [k])+                                  [ ASSERT(null fl || lengthExceeds fl j)+                                    arg t sb' ib' (if null fl+                                                      then Nothing+                                                      else Just (fl !! j))+                                  | (t,sb',ib',j) <- zip4 l sb ib [0..] ]          arg :: Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type         arg t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of@@ -739,14 +737,13 @@      datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys     datacon_vars = map fst datacon_varTys-    us'          = us + n_args      datacon_rdr  = getRdrName datacon      from_alt     = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)-    from_alt_rhs = genLR_E i n (mkProd_E gk_ us' datacon_varTys)+    from_alt_rhs = genLR_E i n (mkProd_E gk_ datacon_varTys) -    to_alt     = ( genLR_P i n (mkProd_P gk us' datacon_varTys)+    to_alt     = ( genLR_P i n (mkProd_P gk datacon_varTys)                  , to_alt_rhs                  ) -- These M1s are meta-information for the datatype     to_alt_rhs = case gk_ of@@ -788,13 +785,11 @@  -- Build a product expression mkProd_E :: GenericKind_DC    -- Generic or Generic1?-         -> US                -- Base for unique names          -> [(RdrName, Type)]                        -- List of variables matched on the lhs and their types          -> LHsExpr GhcPs   -- Resulting product expression-mkProd_E _   _ []     = mkM1_E (nlHsVar u1DataCon_RDR)-mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars)-                     -- These M1s are meta-information for the constructor+mkProd_E gk_ varTys = mkM1_E (foldBal prod (nlHsVar u1DataCon_RDR) appVars)+                      -- These M1s are meta-information for the constructor   where     appVars = map (wrapArg_E gk_) varTys     prod a b = prodDataCon_RDR `nlHsApps` [a,b]@@ -833,12 +828,10 @@  -- Build a product pattern mkProd_P :: GenericKind       -- Gen0 or Gen1-         -> US                -- Base for unique names          -> [(RdrName, Type)] -- List of variables to match,                               --   along with their types          -> LPat GhcPs      -- Resulting product pattern-mkProd_P _  _ []     = mkM1_P (nlNullaryConPat u1DataCon_RDR)-mkProd_P gk _ varTys = mkM1_P (foldBal prod appVars)+mkProd_P gk varTys = mkM1_P (foldBal prod (nlNullaryConPat u1DataCon_RDR) appVars)                      -- These M1s are meta-information for the constructor   where     appVars = unzipWith (wrapArg_P gk) varTys@@ -870,15 +863,12 @@ nlHsCompose :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs nlHsCompose x y = compose_RDR `nlHsApps` [x, y] --- | Variant of foldr1 for producing balanced lists-foldBal :: (a -> a -> a) -> [a] -> a-foldBal op = foldBal' op (error "foldBal: empty list")--foldBal' :: (a -> a -> a) -> a -> [a] -> a-foldBal' _  x []  = x-foldBal' _  _ [y] = y-foldBal' op x l   = let (a,b) = splitAt (length l `div` 2) l-                    in foldBal' op x a `op` foldBal' op x b+-- | Variant of foldr for producing balanced lists+foldBal :: (a -> a -> a) -> a -> [a] -> a+foldBal _  x []  = x+foldBal _  _ [y] = y+foldBal op x l   = let (a,b) = splitAt (length l `div` 2) l+                   in foldBal op x a `op` foldBal op x b  {- Note [Generics and unlifted types]@@ -890,7 +880,7 @@ to see if the type is actually one of the unlifted types for which URec has a data family instance; if so, we generate that instead. -See wiki:Commentary/Compiler/GenericDeriving#Handlingunliftedtypes for more+See wiki:commentary/compiler/generic-deriving#handling-unlifted-types for more details on why URec is implemented the way it is.  Note [Generating a correctly typed Rep instance]@@ -906,7 +896,7 @@ result, tc_mkRepTy builds the most generalized Rep(1) instance possible using the type variables it learns from the TyCon (i.e., it uses tyConTyVars). This can cause problems when the instance has instantiated type variables-(see Trac #11732). As an example:+(see #11732). As an example:      data T a = MkT a     deriving instance Generic (T Int)@@ -990,7 +980,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Deriving Generic(1) is known to have a large constant factor during compilation, which contributes to noticeable compilation slowdowns when-deriving Generic(1) for large datatypes (see Trac #5642).+deriving Generic(1) for large datatypes (see #5642).  To ease the pain, there is a trick one can play when generating definitions for to(1) and from(1). If you have a datatype like:
compiler/typecheck/TcHoleErrors.hs view
@@ -1,11 +1,25 @@-module TcHoleErrors ( findValidHoleFits, tcFilterHoleFits, HoleFit (..)-                    , HoleFitCandidate (..), tcCheckHoleFit, tcSubsumes-                    , withoutUnification ) where+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ExistentialQuantification #-}+module TcHoleErrors ( findValidHoleFits, tcFilterHoleFits+                    , tcCheckHoleFit, tcSubsumes+                    , withoutUnification+                    , fromPureHFPlugin+                    -- Re-exports for convenience+                    , hfIsLcl+                    , pprHoleFit, debugHoleFitDispConfig +                    -- Re-exported from TcHoleFitTypes+                    , TypedHole (..), HoleFit (..), HoleFitCandidate (..)+                    , CandPlugin, FitPlugin+                    , HoleFitPlugin (..), HoleFitPluginR (..)+                    ) where+ import GhcPrelude  import TcRnTypes import TcRnMonad+import Constraint+import TcOrigin import TcMType import TcEvidence import TcType@@ -28,10 +42,9 @@  import Control.Arrow ( (&&&) ) -import Control.Monad    ( filterM, replicateM )+import Control.Monad    ( filterM, replicateM, foldM ) import Data.List        ( partition, sort, sortOn, nubBy ) import Data.Graph       ( graphFromEdges, topSort )-import Data.Function    ( on )   import TcSimplify    ( simpl_top, runTcSDeriveds )@@ -39,13 +52,15 @@  import ExtractDocs ( extractDocs ) import qualified Data.Map as Map-import HsDoc           ( HsDocString, unpackHDS, DeclDocMap(..) )-import HscTypes        ( ModIface(..) )+import GHC.Hs.Doc      ( unpackHDS, DeclDocMap(..) )+import HscTypes        ( ModIface_(..) ) import LoadIface       ( loadInterfaceForNameMaybe )  import PrelInfo (knownKeyNames) +import TcHoleFitTypes + {- Note [Valid hole fits include ...] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -323,7 +338,7 @@ Note [Relevant Constraints] ~~~~~~~~~~~~~~~~~~~ -As highlighted by Trac #14273, we need to check any relevant constraints as well+As highlighted by #14273, we need to check any relevant constraints as well as checking for subsumption. Relevant constraints are the simple constraints whose free unification variables are mentioned in the type of the hole. @@ -420,72 +435,6 @@                               then BySize                               else NoSorting } ---- | HoleFitCandidates are passed to the filter and checked whether they can be--- made to fit.-data HoleFitCandidate = IdHFCand Id             -- An id, like locals.-                      | NameHFCand Name         -- A name, like built-in syntax.-                      | GreHFCand GlobalRdrElt  -- A global, like imported ids.-                      deriving (Eq)-instance Outputable HoleFitCandidate where-  ppr = pprHoleFitCand--pprHoleFitCand :: HoleFitCandidate -> SDoc-pprHoleFitCand (IdHFCand id) = text "Id HFC: " <> ppr id-pprHoleFitCand (NameHFCand name) = text "Name HFC: " <> ppr name-pprHoleFitCand (GreHFCand gre) = text "Gre HFC: " <> ppr gre--instance HasOccName HoleFitCandidate where-  occName hfc = case hfc of-                  IdHFCand id -> occName id-                  NameHFCand name -> occName name-                  GreHFCand gre -> occName (gre_name gre)---- | HoleFit is the type we use for valid hole fits. It contains the--- element that was checked, the Id of that element as found by `tcLookup`,--- and the refinement level of the fit, which is the number of extra argument--- holes that this fit uses (e.g. if hfRefLvl is 2, the fit is for `Id _ _`).-data HoleFit =-  HoleFit { hfId   :: Id       -- The elements id in the TcM-          , hfCand :: HoleFitCandidate  -- The candidate that was checked.-          , hfType :: TcType -- The type of the id, possibly zonked.-          , hfRefLvl :: Int  -- The number of holes in this fit.-          , hfWrap :: [TcType] -- The wrapper for the match.-          , hfMatches :: [TcType]  -- What the refinement variables got matched-                                   -- with, if anything-          , hfDoc :: Maybe HsDocString } -- Documentation of this HoleFit, if-                                         -- available.---hfName :: HoleFit -> Name-hfName hf = case hfCand hf of-              IdHFCand id -> idName id-              NameHFCand name -> name-              GreHFCand gre -> gre_name gre--hfIsLcl :: HoleFit -> Bool-hfIsLcl hf = case hfCand hf of-               IdHFCand _    -> True-               NameHFCand _  -> False-               GreHFCand gre -> gre_lcl gre---- We define an Eq and Ord instance to be able to build a graph.-instance Eq HoleFit where-   (==) = (==) `on` hfId---- We compare HoleFits by their name instead of their Id, since we don't--- want our tests to be affected by the non-determinism of `nonDetCmpVar`,--- which is used to compare Ids. When comparing, we want HoleFits with a lower--- refinement level to come first.-instance Ord HoleFit where-  compare a b = cmp a b-    where cmp  = if hfRefLvl a == hfRefLvl b-                 then compare `on` hfName-                 else compare `on` hfRefLvl--instance Outputable HoleFit where-    ppr = pprHoleFit debugHoleFitDispConfig- -- If enabled, we go through the fits and add any associated documentation, -- by looking it up in the module or the environment (for local fits) addDocs :: [HoleFit] -> TcM [HoleFit]@@ -499,62 +448,71 @@    msg = text "TcHoleErrors addDocs"    lookupInIface name (ModIface { mi_decl_docs = DeclDocMap dmap })      = Map.lookup name dmap-   upd lclDocs fit =-     let name = hfName fit in-     do { doc <- if hfIsLcl fit-                 then pure (Map.lookup name lclDocs)-                 else do { mbIface <- loadInterfaceForNameMaybe msg name-                         ; return $ mbIface >>= lookupInIface name }-        ; return $ fit {hfDoc = doc} }+   upd lclDocs fit@(HoleFit {hfCand = cand}) =+        do { let name = getName cand+           ; doc <- if hfIsLcl fit+                    then pure (Map.lookup name lclDocs)+                    else do { mbIface <- loadInterfaceForNameMaybe msg name+                            ; return $ mbIface >>= lookupInIface name }+           ; return $ fit {hfDoc = doc} }+   upd _ fit = return fit  -- For pretty printing hole fits, we display the name and type of the fit, -- with added '_' to represent any extra arguments in case of a non-zero -- refinement level. pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc-pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) hf = hang display 2 provenance-    where name = hfName hf-          ty = hfType hf-          matches =  hfMatches hf-          wrap = hfWrap hf-          tyApp = sep $ map ((text "@" <>) . pprParendType) wrap-          tyAppVars = sep $ punctuate comma $-              map (\(v,t) -> ppr v <+> text "~" <+> pprParendType t) $-                zip vars wrap-            where-              vars = unwrapTypeVars ty-              -- Attempts to get all the quantified type variables in a type,-              -- e.g.-              -- return :: forall (m :: * -> *) Monad m => (forall a . a) -> m a-              -- into [m, a]-              unwrapTypeVars :: Type -> [TyVar]-              unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of-                                  Just (_, unfunned) -> unwrapTypeVars unfunned-                                  _ -> []-                where (vars, unforalled) = splitForAllTys t-          holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) matches-          holeDisp = if sMs then holeVs-                     else sep $ replicate (length matches) $ text "_"-          occDisp = pprPrefixOcc name-          tyDisp = ppWhen sTy $ dcolon <+> ppr ty-          has = not . null-          wrapDisp = ppWhen (has wrap && (sWrp || sWrpVars))-                      $ text "with" <+> if sWrp || not sTy-                                        then occDisp <+> tyApp-                                        else tyAppVars-          docs = case hfDoc hf of-                   Just d -> text "{-^" <>-                             (vcat . map text . lines . unpackHDS) d-                             <> text "-}"-                   _ -> empty-          funcInfo = ppWhen (has matches && sTy) $-                       text "where" <+> occDisp <+> tyDisp-          subDisp = occDisp <+> if has matches then holeDisp else tyDisp-          display =  subDisp $$ nest 2 (funcInfo $+$ docs $+$ wrapDisp)-          provenance = ppWhen sProv $ parens $-                case hfCand hf of-                    GreHFCand gre -> pprNameProvenance gre-                    _ -> text "bound at" <+> ppr (getSrcLoc name)+pprHoleFit _ (RawHoleFit sd) = sd+pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) =+ hang display 2 provenance+ where name =  getName hfCand+       tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap+         where pprArg b arg = case binderArgFlag b of+                                Specified -> text "@" <> pprParendType arg+                                -- Do not print type application for inferred+                                -- variables (#16456)+                                Inferred  -> empty+                                Required  -> pprPanic "pprHoleFit: bad Required"+                                                         (ppr b <+> ppr arg)+       tyAppVars = sep $ punctuate comma $+           zipWithEqual "pprHoleFit" (\v t -> ppr (binderVar v) <+>+                                               text "~" <+> pprParendType t)+           vars hfWrap +       vars = unwrapTypeVars hfType+         where+           -- Attempts to get all the quantified type variables in a type,+           -- e.g.+           -- return :: forall (m :: * -> *) Monad m => (forall a . a -> m a)+           -- into [m, a]+           unwrapTypeVars :: Type -> [TyCoVarBinder]+           unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of+                               Just (_, unfunned) -> unwrapTypeVars unfunned+                               _ -> []+             where (vars, unforalled) = splitForAllVarBndrs t+       holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches+       holeDisp = if sMs then holeVs+                  else sep $ replicate (length hfMatches) $ text "_"+       occDisp = pprPrefixOcc name+       tyDisp = ppWhen sTy $ dcolon <+> ppr hfType+       has = not . null+       wrapDisp = ppWhen (has hfWrap && (sWrp || sWrpVars))+                   $ text "with" <+> if sWrp || not sTy+                                     then occDisp <+> tyApp+                                     else tyAppVars+       docs = case hfDoc of+                Just d -> text "{-^" <>+                          (vcat . map text . lines . unpackHDS) d+                          <> text "-}"+                _ -> empty+       funcInfo = ppWhen (has hfMatches && sTy) $+                    text "where" <+> occDisp <+> tyDisp+       subDisp = occDisp <+> if has hfMatches then holeDisp else tyDisp+       display =  subDisp $$ nest 2 (funcInfo $+$ docs $+$ wrapDisp)+       provenance = ppWhen sProv $ parens $+             case hfCand of+                 GreHFCand gre -> pprNameProvenance gre+                 _ -> text "bound at" <+> ppr (getSrcLoc name)+ getLocalBindings :: TidyEnv -> Ct -> TcM [Id] getLocalBindings tidy_orig ct  = do { (env1, _) <- zonkTidyOrigin tidy_orig (ctLocOrigin loc)@@ -589,11 +547,15 @@      ; maxVSubs <- maxValidHoleFits <$> getDynFlags      ; hfdc <- getHoleFitDispConfig      ; sortingAlg <- getSortingAlg+     ; dflags <- getDynFlags+     ; hfPlugs <- tcg_hf_plugins <$> getGblEnv      ; let findVLimit = if sortingAlg > NoSorting then Nothing else maxVSubs-     ; refLevel <- refLevelHoleFits <$> getDynFlags-     ; traceTc "findingValidHoleFitsFor { " $ ppr ct+           refLevel = refLevelHoleFits dflags+           hole = TyH (listToBag relevantCts) implics (Just ct)+           (candidatePlugins, fitPlugins) =+             unzip $ map (\p-> ((candPlugin p) hole, (fitPlugin p) hole)) hfPlugs+     ; traceTc "findingValidHoleFitsFor { " $ ppr hole      ; traceTc "hole_lvl is:" $ ppr hole_lvl-     ; traceTc "implics are: " $ ppr implics      ; traceTc "simples are: " $ ppr simples      ; traceTc "locals are: " $ ppr lclBinds      ; let (lcl, gbl) = partition gre_lcl (globalRdrEnvElts rdr_env)@@ -606,11 +568,14 @@            globals = map GreHFCand gbl            syntax = map NameHFCand builtIns            to_check = locals ++ syntax ++ globals+     ; cands <- foldM (flip ($)) to_check candidatePlugins+     ; traceTc "numPlugins are:" $ ppr (length candidatePlugins)      ; (searchDiscards, subs) <--        tcFilterHoleFits findVLimit implics relevantCts (hole_ty, []) to_check+        tcFilterHoleFits findVLimit hole (hole_ty, []) cands      ; (tidy_env, tidy_subs) <- zonkSubs tidy_env subs      ; tidy_sorted_subs <- sortFits sortingAlg tidy_subs-     ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs tidy_sorted_subs+     ; plugin_handled_subs <- foldM (flip ($)) tidy_sorted_subs fitPlugins+     ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs plugin_handled_subs            vDiscards = pVDisc || searchDiscards      ; subs_with_docs <- addDocs limited_subs      ; let vMsg = ppUnless (null subs_with_docs) $@@ -629,8 +594,8 @@             ; traceTc "ref_tys are" $ ppr ref_tys             ; let findRLimit = if sortingAlg > NoSorting then Nothing                                                          else maxRSubs-            ; refDs <- mapM (flip (tcFilterHoleFits findRLimit implics-                                     relevantCts) to_check) ref_tys+            ; refDs <- mapM (flip (tcFilterHoleFits findRLimit hole)+                              cands) ref_tys             ; (tidy_env, tidy_rsubs) <- zonkSubs tidy_env $ concatMap snd refDs             ; tidy_sorted_rsubs <- sortFits sortingAlg tidy_rsubs             -- For refinement substitutions we want matches@@ -640,8 +605,10 @@             ; (tidy_env, tidy_hole_ty) <- zonkTidyTcType tidy_env hole_ty             ; let hasExactApp = any (tcEqType tidy_hole_ty) . hfWrap                   (exact, not_exact) = partition hasExactApp tidy_sorted_rsubs-                  (pRDisc, exact_last_rfits) =-                    possiblyDiscard maxRSubs $ not_exact ++ exact+            ; plugin_handled_rsubs <- foldM (flip ($))+                                        (not_exact ++ exact) fitPlugins+            ; let (pRDisc, exact_last_rfits) =+                    possiblyDiscard maxRSubs $ plugin_handled_rsubs                   rDiscards = pRDisc || any fst refDs             ; rsubs_with_docs <- addDocs exact_last_rfits             ; return (tidy_env,@@ -676,7 +643,7 @@       where newTyVars = replicateM refLvl $ setLvl <$>                             (newOpenTypeKind >>= newFlexiTyVar)             setLvl = flip setMetaTyVarTcLevel hole_lvl-            wrapWithVars vars = mkFunTys (map mkTyVarTy vars) hole_ty+            wrapWithVars vars = mkVisFunTys (map mkTyVarTy vars) hole_ty      sortFits :: SortingAlg    -- How we should sort the hole fits              -> [HoleFit]     -- The subs to sort@@ -723,6 +690,9 @@       where zonkSubs' zs env [] = return (env, reverse zs)             zonkSubs' zs env (hf:hfs) = do { (env', z) <- zonkSub env hf                                            ; zonkSubs' (z:zs) env' hfs }++            zonkSub :: TidyEnv -> HoleFit -> TcM (TidyEnv, HoleFit)+            zonkSub env hf@RawHoleFit{} = return (env, hf)             zonkSub env hf@HoleFit{hfType = ty, hfMatches = m, hfWrap = wrp}               = do { (env, ty') <- zonkTidyTcType env ty                    ; (env, m') <- zonkTidyTcTypes env m@@ -777,10 +747,7 @@ -- running the type checker. Stops after finding limit matches. tcFilterHoleFits :: Maybe Int                -- ^ How many we should output, if limited-               -> [Implication]-               -- ^ Enclosing implications for givens-               -> [Ct]-               -- ^ Any relevant unsolved simple constraints+               -> TypedHole -- ^ The hole to filter against                -> (TcType, [TcTyVar])                -- ^ The type to check for fits and a list of refinement                -- variables (free type variables in the type) for emulating@@ -790,8 +757,8 @@                -> TcM (Bool, [HoleFit])                -- ^ We return whether or not we stopped due to hitting the limit                -- and the fits we found.-tcFilterHoleFits (Just 0) _ _ _ _ = return (False, []) -- Stop right away on 0-tcFilterHoleFits limit implics relevantCts ht@(hole_ty, _) candidates =+tcFilterHoleFits (Just 0) _ _ _ = return (False, []) -- Stop right away on 0+tcFilterHoleFits limit (TyH {..}) ht@(hole_ty, _) candidates =   do { traceTc "checkingFitsFor {" $ ppr hole_ty      ; (discards, subs) <- go [] emptyVarSet limit ht candidates      ; traceTc "checkingFitsFor }" empty@@ -892,7 +859,7 @@     -- refinement hole fits, so we can't wrap the side-effects deeper than this.       withoutUnification fvs $       do { traceTc "checkingFitOf {" $ ppr ty-         ; (fits, wrp) <- tcCheckHoleFit (listToBag relevantCts) implics h_ty ty+         ; (fits, wrp) <- tcCheckHoleFit hole h_ty ty          ; traceTc "Did it fit?" $ ppr fits          ; traceTc "wrap is: " $ ppr wrp          ; traceTc "checkingFitOf }" empty@@ -925,6 +892,7 @@                           else return Nothing }            else return Nothing }      where fvs = mkFVs ref_vars `unionFV` hole_fvs `unionFV` tyCoFVsOfType ty+           hole = TyH tyHRelevantCts tyHImplics Nothing   subsDiscardMsg :: SDoc@@ -961,8 +929,8 @@ -- discarding any errors. Subsumption here means that the ty_b can fit into the -- ty_a, i.e. `tcSubsumes a b == True` if b is a subtype of a. tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool-tcSubsumes ty_a ty_b = fst <$> tcCheckHoleFit emptyBag [] ty_a ty_b-+tcSubsumes ty_a ty_b = fst <$> tcCheckHoleFit dummyHole ty_a ty_b+  where dummyHole = TyH emptyBag [] Nothing  -- | A tcSubsumes which takes into account relevant constraints, to fix trac -- #14273. This makes sure that when checking whether a type fits the hole,@@ -970,24 +938,22 @@ -- constraints on the type of the hole. -- Note: The simplifier may perform unification, so make sure to restore any -- free type variables to avoid side-effects.-tcCheckHoleFit :: Cts                   -- ^  Any relevant Cts to the hole.-               -> [Implication]-               -- ^ The nested implications of the hole with the innermost-               -- implication first.-               -> TcSigmaType           -- ^ The type of the hole.-               -> TcSigmaType           -- ^ The type to check whether fits.+tcCheckHoleFit :: TypedHole   -- ^ The hole to check against+               -> TcSigmaType+               -- ^ The type to check against (possibly modified, e.g. refined)+               -> TcSigmaType -- ^ The type to check whether fits.                -> TcM (Bool, HsWrapper)                -- ^ Whether it was a match, and the wrapper from hole_ty to ty.-tcCheckHoleFit _ _ hole_ty ty | hole_ty `eqType` ty+tcCheckHoleFit _ hole_ty ty | hole_ty `eqType` ty     = return (True, idHsWrapper)-tcCheckHoleFit relevantCts implics hole_ty ty = discardErrs $+tcCheckHoleFit (TyH {..}) hole_ty ty = discardErrs $   do { -- We wrap the subtype constraint in the implications to pass along the        -- givens, and so we must ensure that any nested implications and skolems        -- end up with the correct level. The implications are ordered so that        -- the innermost (the one with the highest level) is first, so it        -- suffices to get the level of the first one (or the current level, if        -- there are no implications involved).-       innermost_lvl <- case implics of+       innermost_lvl <- case tyHImplics of                           [] -> getTcLevel                           -- imp is the innermost implication                           (imp:_) -> return (ic_tclvl imp)@@ -995,15 +961,15 @@                           tcSubType_NC ExprSigCtxt ty hole_ty      ; traceTc "Checking hole fit {" empty      ; traceTc "wanteds are: " $ ppr wanted-     ; if isEmptyWC wanted && isEmptyBag relevantCts+     ; if isEmptyWC wanted && isEmptyBag tyHRelevantCts        then traceTc "}" empty >> return (True, wrp)        else do { fresh_binds <- newTcEvBinds                 -- The relevant constraints may contain HoleDests, so we must                 -- take care to clone them as well (to avoid #15370).-               ; cloned_relevants <- mapBagM cloneWanted relevantCts+               ; cloned_relevants <- mapBagM cloneWanted tyHRelevantCts                  -- We wrap the WC in the nested implications, see                  -- Note [Nested Implications]-               ; let outermost_first = reverse implics+               ; let outermost_first = reverse tyHImplics                      setWC = setWCAndBinds fresh_binds                     -- We add the cloned relevants to the wanteds generated by                     -- the call to tcSubType_NC, see Note [Relevant Constraints]@@ -1026,3 +992,10 @@        setWCAndBinds binds imp wc          = WC { wc_simple = emptyBag               , wc_impl = unitBag $ imp { ic_wanted = wc , ic_binds = binds } }++-- | Maps a plugin that needs no state to one with an empty one.+fromPureHFPlugin :: HoleFitPlugin -> HoleFitPluginR+fromPureHFPlugin plug =+  HoleFitPluginR { hfPluginInit = newTcRef ()+                 , hfPluginRun = const plug+                 , hfPluginStop = const $ return () }
compiler/typecheck/TcHoleErrors.hs-boot view
@@ -4,7 +4,8 @@ -- + which calls 'TcSimplify.simpl_top' module TcHoleErrors where -import TcRnTypes  ( TcM, Ct, Implication )+import TcRnTypes  ( TcM )+import Constraint ( Ct, Implication ) import Outputable ( SDoc ) import VarEnv     ( TidyEnv )
compiler/typecheck/TcHsSyn.hs view
@@ -16,7 +16,7 @@  module TcHsSyn (         -- * Extracting types from HsSyn-        hsLitType, hsLPatType, hsPatType,+        hsLitType, hsPatType, hsLPatType,          -- * Other HsSyn functions         mkHsDictLet, mkHsApp,@@ -34,7 +34,7 @@         zonkTopBndrs,         ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv,         zonkTyVarBinders, zonkTyVarBindersX, zonkTyVarBinderX,-        zonkTyBndrs, zonkTyBndrsX,+        zonkTyBndrs, zonkTyBndrsX, zonkRecTyVarBndrs,         zonkTcTypeToType,  zonkTcTypeToTypeX,         zonkTcTypesToTypes, zonkTcTypesToTypesX,         zonkTyVarOcc,@@ -44,13 +44,14 @@         lookupTyVarOcc   ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude -import HsSyn+import GHC.Hs import Id import IdInfo+import Predicate import TcRnMonad import PrelNames import BuildTyCl ( TcMethInfo, MethInfo )@@ -58,6 +59,7 @@ import TcMType import TcEnv   ( tcLookupGlobalOnly ) import TcEvidence+import TyCoPpr ( pprTyVar ) import TysPrim import TyCon import TysWiredIn@@ -96,8 +98,8 @@  -} -hsLPatType :: OutPat GhcTc -> Type-hsLPatType lpat = hsPatType (unLoc lpat)+hsLPatType :: LPat GhcTc -> Type+hsLPatType (dL->L _ p) = hsPatType p  hsPatType :: Pat GhcTc -> Type hsPatType (ParPat _ pat)                = hsLPatType pat@@ -110,7 +112,8 @@ hsPatType (ViewPat ty _ _)              = ty hsPatType (ListPat (ListPatTc ty Nothing) _)      = mkListTy ty hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty-hsPatType (TuplePat tys _ bx)           = mkTupleTy bx tys+hsPatType (TuplePat tys _ bx)           = mkTupleTy1 bx tys+                  -- See Note [Don't flatten tuples from HsSyn] in MkCore hsPatType (SumPat tys _ _ _ )           = mkSumTy tys hsPatType (ConPatOut { pat_con = lcon                      , pat_arg_tys = tys })@@ -119,7 +122,9 @@ hsPatType (NPat ty _ _ _)               = ty hsPatType (NPlusKPat ty _ _ _ _ _)      = ty hsPatType (CoPat _ _ _ ty)              = ty-hsPatType p                             = pprPanic "hsPatType" (ppr p)+hsPatType (XPat n)                      = noExtCon n+hsPatType ConPatIn{}                    = panic "hsPatType: ConPatIn"+hsPatType SplicePat{}                   = panic "hsPatType: SplicePat"  hsLitType :: HsLit (GhcPass p) -> TcType hsLitType (HsChar _ _)       = charTy@@ -135,15 +140,15 @@ hsLitType (HsRat _ _ ty)     = ty hsLitType (HsFloatPrim _ _)  = floatPrimTy hsLitType (HsDoublePrim _ _) = doublePrimTy-hsLitType (XLit p)           = pprPanic "hsLitType" (ppr p)+hsLitType (XLit nec)         = noExtCon nec  -- Overloaded literals. Here mainly because it uses isIntTy etc  shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId) shortCutLit dflags (HsIntegral int@(IL src neg i)) ty-  | isIntTy ty  && inIntRange  dflags i = Just (HsLit noExt (HsInt noExt int))+  | isIntTy ty  && inIntRange  dflags i = Just (HsLit noExtField (HsInt noExtField int))   | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim src i))-  | isIntegerTy ty = Just (HsLit noExt (HsInteger src i ty))+  | isIntegerTy ty = Just (HsLit noExtField (HsInteger src i ty))   | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit neg i)) ty         -- The 'otherwise' case is important         -- Consider (3 :: Float).  Syntactically it looks like an IntLit,@@ -152,16 +157,16 @@         -- literals, compiled without -O  shortCutLit _ (HsFractional f) ty-  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim noExt f))-  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExt f))+  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim noExtField f))+  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExtField f))   | otherwise     = Nothing  shortCutLit _ (HsIsString src s) ty-  | isStringTy ty = Just (HsLit noExt (HsString src s))+  | isStringTy ty = Just (HsLit noExtField (HsString src s))   | otherwise     = Nothing  mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc-mkLit con lit = HsApp noExt (nlHsDataCon con) (nlHsLit lit)+mkLit con lit = HsApp noExtField (nlHsDataCon con) (nlHsLit lit)  ------------------------------ hsOverLitName :: OverLitVal -> Name@@ -204,6 +209,7 @@             , ze_tv_env :: TyCoVarEnv TyCoVar             , ze_id_env :: IdEnv      Id             , ze_meta_tv_env :: TcRef (TyVarEnv Type) }+ {- Note [The ZonkEnv] ~~~~~~~~~~~~~~~~~~~~~ * ze_flexi :: ZonkFlexi says what to do with a@@ -277,7 +283,11 @@   | RuntimeUnkFlexi -- Used in the GHCi debugger  instance Outputable ZonkEnv where-  ppr (ZonkEnv { ze_id_env =  var_env}) = pprUFM var_env (vcat . map ppr)+  ppr (ZonkEnv { ze_tv_env = tv_env+               , ze_id_env = id_env })+    = text "ZE" <+> braces (vcat+         [ text "ze_tv_env =" <+> ppr tv_env+         , text "ze_id_env =" <+> ppr id_env ])  -- The EvBinds have to already be zonked, but that's usually the case. emptyZonkEnv :: TcM ZonkEnv@@ -291,9 +301,9 @@                          , ze_id_env = emptyVarEnv                          , ze_meta_tv_env = mtv_env_ref }) } -initZonkEnv :: (ZonkEnv -> a -> TcM b) -> a -> TcM b-initZonkEnv do_it x = do { ze <- mkEmptyZonkEnv DefaultFlexi-                         ; do_it ze x }+initZonkEnv :: (ZonkEnv -> TcM b) -> TcM b+initZonkEnv thing_inside = do { ze <- mkEmptyZonkEnv DefaultFlexi+                              ; thing_inside ze }  -- | Extend the knot-tied environment. extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv@@ -323,6 +333,12 @@ extendTyZonkEnv1 ze@(ZonkEnv { ze_tv_env = ty_env }) tv   = ze { ze_tv_env = extendVarEnv ty_env tv tv } +extendTyZonkEnvN :: ZonkEnv -> [(Name,TyVar)] -> ZonkEnv+extendTyZonkEnvN ze@(ZonkEnv { ze_tv_env = ty_env }) pairs+  = ze { ze_tv_env = foldl add ty_env pairs }+  where+    add env (name, tv) = extendVarEnv_Directly env (getUnique name) tv+ setZonkType :: ZonkEnv -> ZonkFlexi -> ZonkEnv setZonkType ze flexi = ze { ze_flexi = flexi } @@ -373,12 +389,12 @@ zonkIdBndrs env ids = mapM (zonkIdBndr env) ids  zonkTopBndrs :: [TcId] -> TcM [Id]-zonkTopBndrs ids = initZonkEnv zonkIdBndrs ids+zonkTopBndrs ids = initZonkEnv $ \ ze -> zonkIdBndrs ze ids  zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc) zonkFieldOcc env (FieldOcc sel lbl)   = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel-zonkFieldOcc _ (XFieldOcc _) = panic "zonkFieldOcc"+zonkFieldOcc _ (XFieldOcc nec) = noExtCon nec  zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var]) zonkEvBndrsX = mapAccumLM zonkEvBndrX@@ -418,7 +434,7 @@ zonkCoreBndrsX = mapAccumLM zonkCoreBndrX  zonkTyBndrs :: [TcTyVar] -> TcM (ZonkEnv, [TyVar])-zonkTyBndrs = initZonkEnv zonkTyBndrsX+zonkTyBndrs tvs = initZonkEnv $ \ze -> zonkTyBndrsX ze tvs  zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar]) zonkTyBndrsX = mapAccumLM zonkTyBndrX@@ -435,7 +451,7 @@  zonkTyVarBinders ::  [VarBndr TcTyVar vis]                  -> TcM (ZonkEnv, [VarBndr TyVar vis])-zonkTyVarBinders = initZonkEnv zonkTyVarBindersX+zonkTyVarBinders tvbs = initZonkEnv $ \ ze -> zonkTyVarBindersX ze tvbs  zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis]                              -> TcM (ZonkEnv, [VarBndr TyVar vis])@@ -448,11 +464,27 @@   = do { (env', tv') <- zonkTyBndrX env tv        ; return (env', Bndr tv' vis) } +zonkRecTyVarBndrs :: [Name] -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])+-- This rather specialised function is used in exactly one place.+-- See Note [Tricky scoping in generaliseTcTyCon] in TcTyClsDecls.+zonkRecTyVarBndrs names tc_tvs+  = initZonkEnv $ \ ze ->+    fixM $ \ ~(_, rec_new_tvs) ->+    do { let ze' = extendTyZonkEnvN ze $+                   zipWithLazy (\ tc_tv new_tv -> (getName tc_tv, new_tv))+                               tc_tvs rec_new_tvs+       ; new_tvs <- zipWithM (zonk_one ze') names tc_tvs+       ; return (ze', new_tvs) }+  where+    zonk_one ze name tc_tv+      = do { ki <- zonkTcTypeToTypeX ze (tyVarKind tc_tv)+           ; return (mkTyVar name ki) }+ zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc)-zonkTopExpr e = initZonkEnv zonkExpr e+zonkTopExpr e = initZonkEnv $ \ ze -> zonkExpr ze e  zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc)-zonkTopLExpr e = initZonkEnv zonkLExpr e+zonkTopLExpr e = initZonkEnv $ \ ze -> zonkLExpr ze e  zonkTopDecls :: Bag EvBind              -> LHsBinds GhcTcId@@ -465,7 +497,7 @@                      [LTcSpecPrag],                      [LRuleDecl    GhcTc]) zonkTopDecls ev_binds binds rules imp_specs fords-  = do  { (env1, ev_binds') <- initZonkEnv zonkEvBinds ev_binds+  = do  { (env1, ev_binds') <- initZonkEnv $ \ ze -> zonkEvBinds ze ev_binds         ; (env2, binds')    <- zonkRecMonoBinds env1 binds                         -- Top level is implicitly recursive         ; rules' <- zonkRules env2 rules@@ -505,12 +537,12 @@         = do n' <- mapIPNameTc (zonkIdBndr env) n              e' <- zonkLExpr env e              return (IPBind x n' e')-    zonk_ip_bind (XIPBind _) = panic "zonkLocalBinds : XCIPBind"+    zonk_ip_bind (XIPBind nec) = noExtCon nec -zonkLocalBinds _ (HsIPBinds _ (XHsIPBinds _))-  = panic "zonkLocalBinds" -- Not in typechecker output-zonkLocalBinds _ (XHsLocalBindsLR _)-  = panic "zonkLocalBinds" -- Not in typechecker output+zonkLocalBinds _ (HsIPBinds _ (XHsIPBinds nec))+  = noExtCon nec+zonkLocalBinds _ (XHsLocalBindsLR nec)+  = noExtCon nec  --------------------------------------------- zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc)@@ -570,7 +602,7 @@             ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds             ; new_exports   <- mapM (zonk_export env3) exports             ; return (new_val_binds, new_exports) }-       ; return (AbsBinds { abs_ext = noExt+       ; return (AbsBinds { abs_ext = noExtField                           , abs_tvs = new_tyvars, abs_ev_vars = new_evs                           , abs_ev_binds = new_ev_binds                           , abs_exports = new_exports, abs_binds = new_val_bind@@ -606,7 +638,7 @@                         , abe_poly = new_poly_id                         , abe_mono = zonkIdOcc env mono_id                         , abe_prags = new_prags })-    zonk_export _ (XABExport _) = panic "zonk_bind: XABExport"+    zonk_export _ (XABExport nec) = noExtCon nec  zonk_bind env (PatSynBind x bind@(PSB { psb_id = (dL->L loc id)                                       , psb_args = details@@ -622,8 +654,8 @@                        , psb_def = lpat'                        , psb_dir = dir' } } -zonk_bind _ (PatSynBind _ (XPatSynBind _)) = panic "zonk_bind"-zonk_bind _ (XHsBindsLR _)                 = panic "zonk_bind"+zonk_bind _ (PatSynBind _ (XPatSynBind nec)) = noExtCon nec+zonk_bind _ (XHsBindsLR nec)                 = noExtCon nec  zonkPatSynDetails :: ZonkEnv                   -> HsPatSynDetails (Located TcId)@@ -677,7 +709,7 @@         ; return (MG { mg_alts = cL l ms'                      , mg_ext = MatchGroupTc arg_tys' res_ty'                      , mg_origin = origin }) }-zonkMatchGroup _ _ (XMatchGroup {}) = panic "zonkMatchGroup"+zonkMatchGroup _ _ (XMatchGroup nec) = noExtCon nec  zonkMatch :: ZonkEnv           -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))@@ -688,7 +720,7 @@   = do  { (env1, new_pats) <- zonkPats env pats         ; new_grhss <- zonkGRHSs env1 zBody grhss         ; return (cL loc (match { m_pats = new_pats, m_grhss = new_grhss })) }-zonkMatch _ _ (dL->L  _ (XMatch _)) = panic "zonkMatch"+zonkMatch _ _ (dL->L  _ (XMatch nec)) = noExtCon nec zonkMatch _ _ _ = panic "zonkMatch: Impossible Match"                              -- due to #15884 @@ -705,10 +737,10 @@           = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded                new_rhs <- zBody env2 rhs                return (GRHS xx new_guarded new_rhs)-        zonk_grhs (XGRHS _) = panic "zonkGRHSs"+        zonk_grhs (XGRHS nec) = noExtCon nec     new_grhss <- mapM (wrapLocM zonk_grhs) grhss     return (GRHSs x new_grhss (cL l new_binds))-zonkGRHSs _ _ (XGRHSs _) = panic "zonkGRHSs"+zonkGRHSs _ _ (XGRHSs nec) = noExtCon nec  {- ************************************************************************@@ -814,7 +846,7 @@                                               ; return (cL l (Present x e')) }     zonk_tup_arg (dL->L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t                                             ; return (cL l (Missing t')) }-    zonk_tup_arg (dL->L _ (XTupArg{})) = panic "zonkExpr.XTupArg"+    zonk_tup_arg (dL->L _ (XTupArg nec)) = noExtCon nec     zonk_tup_arg _ = panic "zonk_tup_arg: Impossible Match"                              -- due to #15884 @@ -850,7 +882,7 @@           = do { (env', guard') <- zonkStmts env zonkLExpr guard                ; expr'          <- zonkLExpr env' expr                ; return $ GRHS x guard' expr' }-        zonk_alt (XGRHS _) = panic "zonkExpr.HsMultiIf"+        zonk_alt (XGRHS nec) = noExtCon nec  zonkExpr env (HsLet x (dL->L l binds) expr)   = do (new_env, new_binds) <- zonkLocalBinds env binds@@ -894,7 +926,7 @@  zonkExpr env (ExprWithTySig _ e ty)   = do { e' <- zonkLExpr env e-       ; return (ExprWithTySig noExt e' ty) }+       ; return (ExprWithTySig noExtField e' ty) }  zonkExpr env (ArithSeq expr wit info)   = do (env1, new_wit) <- zonkWit env wit@@ -1030,7 +1062,7 @@        new_ty <- zonkTcTypeToTypeX env ty        return (HsCmdDo new_ty (cL l new_stmts)) -zonkCmd _ (XCmd{}) = panic "zonkCmd"+zonkCmd _ (XCmd nec) = noExtCon nec   @@ -1050,7 +1082,7 @@          -- rules for arrows         return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd)-zonk_cmd_top _ (XCmdTop {}) = panic "zonk_cmd_top"+zonk_cmd_top _ (XCmdTop nec) = noExtCon nec  ------------------------------------------------------------------------- zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)@@ -1083,7 +1115,7 @@         ; e' <- zonkExpr env e         ; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) } -zonkOverLit _ XOverLit{} = panic "zonkOverLit"+zonkOverLit _ (XOverLit nec) = noExtCon nec  ------------------------------------------------------------------------- zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTcId -> TcM (ArithSeqInfo GhcTc)@@ -1139,7 +1171,7 @@             ; (env3, new_return) <- zonkSyntaxExpr env2 return_op             ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs)                                                                    new_return) }-    zonk_branch _ (XParStmtBlock{}) = panic "zonkStmt"+    zonk_branch _ (XParStmtBlock nec) = noExtCon nec  zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs                             , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id@@ -1230,20 +1262,21 @@   = do  { (env1, new_mb_join)   <- zonk_join env mb_join         ; (env2, new_args)      <- zonk_args env1 args         ; new_body_ty           <- zonkTcTypeToTypeX env2 body_ty-        ; return (env2, ApplicativeStmt new_body_ty new_args new_mb_join) }+        ; return ( env2+                 , ApplicativeStmt new_body_ty new_args new_mb_join) }   where     zonk_join env Nothing  = return (env, Nothing)     zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j -    get_pat (_, ApplicativeArgOne _ pat _ _) = pat+    get_pat (_, ApplicativeArgOne _ pat _ _ _) = pat     get_pat (_, ApplicativeArgMany _ _ _ pat) = pat-    get_pat (_, XApplicativeArg _) = panic "zonkStmt"+    get_pat (_, XApplicativeArg nec) = noExtCon nec -    replace_pat pat (op, ApplicativeArgOne x _ a isBody)-      = (op, ApplicativeArgOne x pat a isBody)+    replace_pat pat (op, ApplicativeArgOne x _ a isBody fail_op)+      = (op, ApplicativeArgOne x pat a isBody fail_op)     replace_pat pat (op, ApplicativeArgMany x a b _)       = (op, ApplicativeArgMany x a b pat)-    replace_pat _ (_, XApplicativeArg _) = panic "zonkStmt"+    replace_pat _ (_, XApplicativeArg nec) = noExtCon nec      zonk_args env args       = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args)@@ -1260,16 +1293,17 @@            ; return (env2, (new_op, new_arg) : new_args) }     zonk_args_rev env [] = return (env, []) -    zonk_arg env (ApplicativeArgOne x pat expr isBody)+    zonk_arg env (ApplicativeArgOne x pat expr isBody fail_op)       = do { new_expr <- zonkLExpr env expr-           ; return (ApplicativeArgOne x pat new_expr isBody) }+           ; (_, new_fail) <- zonkSyntaxExpr env fail_op+           ; return (ApplicativeArgOne x pat new_expr isBody new_fail) }     zonk_arg env (ApplicativeArgMany x stmts ret pat)       = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts            ; new_ret           <- zonkExpr env1 ret            ; return (ApplicativeArgMany x new_stmts new_ret pat) }-    zonk_arg _ (XApplicativeArg _) = panic "zonkStmt.XApplicativeArg"+    zonk_arg _ (XApplicativeArg nec) = noExtCon nec -zonkStmt _ _ (XStmtLR _) = panic "zonkStmt"+zonkStmt _ _ (XStmtLR nec) = noExtCon nec  ------------------------------------------------------------------------- zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTcId -> TcM (HsRecordBinds GhcTcId)@@ -1513,7 +1547,7 @@       = do { (env', v') <- zonk_it env v            ; return (env', cL l (RuleBndr x (cL loc v'))) }    zonk_tm_bndr _ (dL->L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig"-   zonk_tm_bndr _ (dL->L _ (XRuleBndr {})) = panic "zonk_tm_bndr XRuleBndr"+   zonk_tm_bndr _ (dL->L _ (XRuleBndr nec)) = noExtCon nec    zonk_tm_bndr _ _ = panic "zonk_tm_bndr: Impossible Match"                             -- due to #15884 @@ -1525,7 +1559,7 @@                     -- DV: used to be return (env,v) but that is plain                     -- wrong because we may need to go inside the kind                     -- of v and zonk there!-zonkRule _ (XRuleDecl _) = panic "zonkRule"+zonkRule _ (XRuleDecl nec) = noExtCon nec  {- ************************************************************************@@ -1650,7 +1684,7 @@          ; return (env1, binds') })   where     collect_ev_bndrs :: Bag EvBind -> [EvVar]-    collect_ev_bndrs = foldrBag add []+    collect_ev_bndrs = foldr add []     add (EvBind { eb_lhs = var }) vars = var : vars  zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind@@ -1659,7 +1693,7 @@           -- Optimise the common case of Refl coercions          -- See Note [Optimise coercion zonking]-         -- This has a very big effect on some programs (eg Trac #5030)+         -- This has a very big effect on some programs (eg #5030)         ; term' <- case getEqPredTys_maybe (idType var') of            Just (r, ty1, ty2) | ty1 `eqType` ty2@@ -1681,7 +1715,7 @@ use Refl on the right, ignoring the actual coercion on the RHS.  This can have a very big effect, because the constraint solver sometimes does go-to a lot of effort to prove Refl!  (Eg when solving  10+3 = 10+3; cf Trac #5030)+to a lot of effort to prove Refl!  (Eg when solving  10+3 = 10+3; cf #5030)   ************************************************************************@@ -1697,7 +1731,7 @@      In TcMType.zonkTcTyVar, we short-circuit (Indirect ty) to     (Indirect zty), see Note [Sharing in zonking] in TcMType. But we-    /can't/ do this when zonking a TcType to a Type (Trac #15552, esp+    /can't/ do this when zonking a TcType to a Type (#15552, esp     comment:3).  Suppose we have         alpha -> alpha@@ -1725,7 +1759,7 @@     the same as zonkTcTypeToType. (If we distinguished TcType from     Type, this issue would have been a type error!) -Solution: (see Trac #15552 for other variants)+Solution: (see #15552 for other variants)      One possible solution is simply not to do the short-circuiting.     That has less sharing, but maybe sharing is rare. And indeed,@@ -1743,9 +1777,9 @@      * The map is of course stateful, held in a TcRef. (That is unlike       the treatment of lexically-scoped variables in ze_tv_env and-      ze_id_env.+      ze_id_env.) -    Is the extra work worth it.  Some non-sytematic perf measurements+    Is the extra work worth it?  Some non-sytematic perf measurements     suggest that compiler allocation is reduced overall (by 0.5% or so)     but compile time really doesn't change. -}@@ -1847,12 +1881,11 @@  zonk_tycomapper :: TyCoMapper ZonkEnv TcM zonk_tycomapper = TyCoMapper-  { tcm_smart = True   -- Establish type invariants-  , tcm_tyvar = zonkTyVarOcc-  , tcm_covar = zonkCoVarOcc-  , tcm_hole  = zonkCoHole+  { tcm_tyvar      = zonkTyVarOcc+  , tcm_covar      = zonkCoVarOcc+  , tcm_hole       = zonkCoHole   , tcm_tycobinder = \env tv _vis -> zonkTyBndrX env tv-  , tcm_tycon = zonkTcTyConToTyCon }+  , tcm_tycon      = zonkTcTyConToTyCon }  -- Zonk a TyCon by changing a TcTyCon to a regular TyCon zonkTcTyConToTyCon :: TcTyCon -> TcM TyCon@@ -1865,13 +1898,13 @@  -- Confused by zonking? See Note [What is zonking?] in TcMType. zonkTcTypeToType :: TcType -> TcM Type-zonkTcTypeToType = initZonkEnv zonkTcTypeToTypeX+zonkTcTypeToType ty = initZonkEnv $ \ ze -> zonkTcTypeToTypeX ze ty  zonkTcTypeToTypeX :: ZonkEnv -> TcType -> TcM Type zonkTcTypeToTypeX = mapType zonk_tycomapper  zonkTcTypesToTypes :: [TcType] -> TcM [Type]-zonkTcTypesToTypes = initZonkEnv zonkTcTypesToTypesX+zonkTcTypesToTypes tys = initZonkEnv $ \ ze -> zonkTcTypesToTypesX ze tys  zonkTcTypesToTypesX :: ZonkEnv -> [TcType] -> TcM [Type] zonkTcTypesToTypesX env tys = mapM (zonkTcTypeToTypeX env) tys
compiler/typecheck/TcHsType.hs view
@@ -7,2871 +7,3491 @@  {-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}--module TcHsType (-        -- Type signatures-        kcClassSigType, tcClassSigType,-        tcHsSigType, tcHsSigWcType,-        tcHsPartialSigType,-        funsSigCtxt, addSigCtxt, pprSigCtxt,--        tcHsClsInstType,-        tcHsDeriv, tcDerivStrategy,-        tcHsTypeApp,-        UserTypeCtxt(..),-        bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol,-            bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol,-        bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol,-            bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol,-        ContextKind(..),--                -- Type checking type and class decls-        kcLookupTcTyCon, bindTyClTyVars,-        etaExpandAlgTyCon, tcbVisibilities,--          -- tyvars-        zonkAndScopedSort,--        -- Kind-checking types-        -- No kind generalisation, no checkValidType-        kcLHsQTyVars,-        tcWildCardBinders,-        tcHsLiftedType,   tcHsOpenType,-        tcHsLiftedTypeNC, tcHsOpenTypeNC,-        tcLHsType, tcLHsTypeUnsaturated, tcCheckLHsType,-        tcHsMbContext, tcHsContext, tcLHsPredType, tcInferApps,-        failIfEmitsConstraints,-        solveEqualities, -- useful re-export--        typeLevelMode, kindLevelMode,--        kindGeneralize, checkExpectedKind, RequireSaturation(..),-        reportFloatingKvs,--        -- Sort-checking kinds-        tcLHsKindSig, badKindSig,--        -- Zonking and promoting-        zonkPromoteType,--        -- Pattern type signatures-        tcHsPatSigType, tcPatSig,--        -- Error messages-        funAppCtxt, addTyConFlavCtxt-   ) where--#include "GhclibHsVersions.h"--import GhcPrelude--import HsSyn-import TcRnMonad-import TcEvidence-import TcEnv-import TcMType-import TcValidity-import TcUnify-import TcIface-import TcSimplify-import TcHsSyn-import TcErrors ( reportAllUnsolved )-import TcType-import Inst   ( tcInstTyBinders, tcInstTyBinder )-import TyCoRep( TyCoBinder(..), TyBinder, tyCoBinderArgFlag )  -- Used in etaExpandAlgTyCon-import Type-import TysPrim-import Coercion-import RdrName( lookupLocalRdrOcc )-import Var-import VarSet-import TyCon-import ConLike-import DataCon-import Class-import Name-import NameSet-import VarEnv-import TysWiredIn-import BasicTypes-import SrcLoc-import Constants ( mAX_CTUPLE_SIZE )-import ErrUtils( MsgDoc )-import Unique-import UniqSet-import Util-import UniqSupply-import Outputable-import FastString-import PrelNames hiding ( wildCardName )-import DynFlags ( WarningFlag (Opt_WarnPartialTypeSignatures) )-import qualified GHC.LanguageExtensions as LangExt--import Maybes-import Data.List ( find )-import Control.Monad--{--        -----------------------------                General notes-        ------------------------------Unlike with expressions, type-checking types both does some checking and-desugars at the same time. This is necessary because we often want to perform-equality checks on the types right away, and it would be incredibly painful-to do this on un-desugared types. Luckily, desugared types are close enough-to HsTypes to make the error messages sane.--During type-checking, we perform as little validity checking as possible.-Generally, after type-checking, you will want to do validity checking, say-with TcValidity.checkValidType.--Validity checking-~~~~~~~~~~~~~~~~~-Some of the validity check could in principle be done by the kind checker,-but not all:--- During desugaring, we normalise by expanding type synonyms.  Only-  after this step can we check things like type-synonym saturation-  e.g.  type T k = k Int-        type S a = a-  Then (T S) is ok, because T is saturated; (T S) expands to (S Int);-  and then S is saturated.  This is a GHC extension.--- Similarly, also a GHC extension, we look through synonyms before complaining-  about the form of a class or instance declaration--- Ambiguity checks involve functional dependencies--Also, in a mutually recursive group of types, we can't look at the TyCon until we've-finished building the loop.  So to keep things simple, we postpone most validity-checking until step (3).--%************************************************************************-%*                                                                      *-              Check types AND do validity checking-*                                                                      *-************************************************************************--}--funsSigCtxt :: [Located Name] -> UserTypeCtxt--- Returns FunSigCtxt, with no redundant-context-reporting,--- form a list of located names-funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False-funsSigCtxt []              = panic "funSigCtxt"--addSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> TcM a -> TcM a-addSigCtxt ctxt hs_ty thing_inside-  = setSrcSpan (getLoc hs_ty) $-    addErrCtxt (pprSigCtxt ctxt hs_ty) $-    thing_inside--pprSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> SDoc--- (pprSigCtxt ctxt <extra> <type>)--- prints    In the type signature for 'f':---              f :: <type>--- The <extra> is either empty or "the ambiguity check for"-pprSigCtxt ctxt hs_ty-  | Just n <- isSigMaybe ctxt-  = hang (text "In the type signature:")-       2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty)--  | otherwise-  = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon)-       2 (ppr hs_ty)--tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type--- This one is used when we have a LHsSigWcType, but in--- a place where wildcards aren't allowed. The renamer has--- already checked this, so we can simply ignore it.-tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty)--kcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM ()-kcClassSigType skol_info names sig_ty-  = discardResult $-    tcClassSigType skol_info names sig_ty-  -- tcClassSigType does a fair amount of extra work that we don't need,-  -- such as ordering quantified variables. But we absolutely do need-  -- to push the level when checking method types and solve local equalities,-  -- and so it seems easier just to call tcClassSigType than selectively-  -- extract the lines of code from tc_hs_sig_type that we really need.-  -- If we don't push the level, we get #16517, where GHC accepts-  --   class C a where-  --     meth :: forall k. Proxy (a :: k) -> ()-  -- Note that k is local to meth -- this is hogwash.--tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type--- Does not do validity checking-tcClassSigType skol_info names sig_ty-  = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $-    snd <$> tc_hs_sig_type skol_info sig_ty (TheKind liftedTypeKind)-       -- Do not zonk-to-Type, nor perform a validity check-       -- We are in a knot with the class and associated types-       -- Zonking and validity checking is done by tcClassDecl-       -- No need to fail here if the type has an error:-       --   If we're in the kind-checking phase, the solveEqualities-       --     in kcTyClGroup catches the error-       --   If we're in the type-checking phase, the solveEqualities-       --     in tcClassDecl1 gets it-       -- Failing fast here degrades the error message in, e.g., tcfail135:-       --   class Foo f where-       --     baa :: f a -> f-       -- If we fail fast, we're told that f has kind `k1` when we wanted `*`.-       -- It should be that f has kind `k2 -> *`, but we never get a chance-       -- to run the solver where the kind of f is touchable. This is-       -- painfully delicate.--tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type--- Does validity checking--- See Note [Recipe for checking a signature]-tcHsSigType ctxt sig_ty-  = addSigCtxt ctxt (hsSigType sig_ty) $-    do { traceTc "tcHsSigType {" (ppr sig_ty)--          -- Generalise here: see Note [Kind generalisation]-       ; (insol, ty) <- tc_hs_sig_type skol_info sig_ty-                                       (expectedKindInCtxt ctxt)-       ; ty <- zonkTcType ty--       ; when insol failM-       -- See Note [Fail fast if there are insoluble kind equalities] in TcSimplify--       ; checkValidType ctxt ty-       ; traceTc "end tcHsSigType }" (ppr ty)-       ; return ty }-  where-    skol_info = SigTypeSkol ctxt--tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn-               -> ContextKind -> TcM (Bool, TcType)--- Kind-checks/desugars an 'LHsSigType',---   solve equalities,---   and then kind-generalizes.--- This will never emit constraints, as it uses solveEqualities interally.--- No validity checking or zonking--- Returns also a Bool indicating whether the type induced an insoluble constraint;--- True <=> constraint is insoluble-tc_hs_sig_type skol_info hs_sig_type ctxt_kind-  | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type-  = do { (tc_lvl, (wanted, (spec_tkvs, ty)))-              <- pushTcLevelM                           $-                 solveLocalEqualitiesX "tc_hs_sig_type" $-                 bindImplicitTKBndrs_Skol sig_vars      $-                 do { kind <- newExpectedKind ctxt_kind--                    ; tc_lhs_type typeLevelMode hs_ty kind }-       -- Any remaining variables (unsolved in the solveLocalEqualities)-       -- should be in the global tyvars, and therefore won't be quantified--       ; spec_tkvs <- zonkAndScopedSort spec_tkvs-       ; let ty1 = mkSpecForAllTys spec_tkvs ty-       ; kvs <- kindGeneralizeLocal wanted ty1-       ; emitResidualTvConstraint skol_info Nothing (kvs ++ spec_tkvs)-                                  tc_lvl wanted--       ; return (insolubleWC wanted, mkInvForAllTys kvs ty1) }--tc_hs_sig_type _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type"--tcTopLHsType :: LHsSigType GhcRn -> ContextKind -> TcM Type--- tcTopLHsType is used for kind-checking top-level HsType where---   we want to fully solve /all/ equalities, and report errors--- Does zonking, but not validity checking because it's used---   for things (like deriving and instances) that aren't---   ordinary types-tcTopLHsType hs_sig_type ctxt_kind-  | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type-  = do { traceTc "tcTopLHsType {" (ppr hs_ty)-       ; (spec_tkvs, ty)-              <- pushTcLevelM_                     $-                 solveEqualities                   $-                 bindImplicitTKBndrs_Skol sig_vars $-                 do { kind <- newExpectedKind ctxt_kind-                    ; tc_lhs_type typeLevelMode hs_ty kind }--       ; spec_tkvs <- zonkAndScopedSort spec_tkvs-       ; let ty1 = mkSpecForAllTys spec_tkvs ty-       ; kvs <- kindGeneralize ty1-       ; final_ty <- zonkTcTypeToType (mkInvForAllTys kvs ty1)-       ; traceTc "End tcTopLHsType }" (vcat [ppr hs_ty, ppr final_ty])-       ; return final_ty}--tcTopLHsType (XHsImplicitBndrs _) _ = panic "tcTopLHsType"--------------------tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], (Class, [Type], [Kind]))--- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause--- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments--- E.g.    class C (a::*) (b::k->k)---         data T a b = ... deriving( C Int )---    returns ([k], C, [k, Int], [k->k])--- Return values are fully zonked-tcHsDeriv hs_ty-  = do { ty <- checkNoErrs $  -- Avoid redundant error report-                              -- with "illegal deriving", below-               tcTopLHsType hs_ty AnyKind-       ; let (tvs, pred)    = splitForAllTys ty-             (kind_args, _) = splitFunTys (typeKind pred)-       ; case getClassPredTys_maybe pred of-           Just (cls, tys) -> return (tvs, (cls, tys, kind_args))-           Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) }---- | Typecheck something within the context of a deriving strategy.--- This is of particular importance when the deriving strategy is @via@.--- For instance:------ @--- deriving via (S a) instance C (T a)--- @------ We need to typecheck @S a@, and moreover, we need to extend the tyvar--- environment with @a@ before typechecking @C (T a)@, since @S a@ quantified--- the type variable @a@.-tcDerivStrategy-  :: forall a.-     Maybe (DerivStrategy GhcRn) -- ^ The deriving strategy-  -> TcM ([TyVar], a) -- ^ The thing to typecheck within the context of the-                      -- deriving strategy, which might quantify some type-                      -- variables of its own.-  -> TcM (Maybe (DerivStrategy GhcTc), [TyVar], a)-     -- ^ The typechecked deriving strategy, all quantified tyvars, and-     -- the payload of the typechecked thing.-tcDerivStrategy mds thing_inside-  = case mds of-      Nothing -> boring_case Nothing-      Just ds -> do (ds', tvs, thing) <- tc_deriv_strategy ds-                    pure (Just ds', tvs, thing)-  where-    tc_deriv_strategy :: DerivStrategy GhcRn-                      -> TcM (DerivStrategy GhcTc, [TyVar], a)-    tc_deriv_strategy StockStrategy    = boring_case StockStrategy-    tc_deriv_strategy AnyclassStrategy = boring_case AnyclassStrategy-    tc_deriv_strategy NewtypeStrategy  = boring_case NewtypeStrategy-    tc_deriv_strategy (ViaStrategy ty) = do-      ty' <- checkNoErrs $-             tcTopLHsType ty AnyKind-      let (via_tvs, via_pred) = splitForAllTys ty'-      tcExtendTyVarEnv via_tvs $ do-        (thing_tvs, thing) <- thing_inside-        pure (ViaStrategy via_pred, via_tvs ++ thing_tvs, thing)--    boring_case :: mds -> TcM (mds, [TyVar], a)-    boring_case mds = do-      (thing_tvs, thing) <- thing_inside-      pure (mds, thing_tvs, thing)--tcHsClsInstType :: UserTypeCtxt    -- InstDeclCtxt or SpecInstCtxt-                -> LHsSigType GhcRn-                -> TcM Type--- Like tcHsSigType, but for a class instance declaration-tcHsClsInstType user_ctxt hs_inst_ty-  = setSrcSpan (getLoc (hsSigType hs_inst_ty)) $-    do { -- Fail eagerly if tcTopLHsType fails.  We are at top level so-         -- these constraints will never be solved later. And failing-         -- eagerly avoids follow-on errors when checkValidInstance-         -- sees an unsolved coercion hole-         inst_ty <- checkNoErrs $-                    tcTopLHsType hs_inst_ty (TheKind constraintKind)-       ; checkValidInstance user_ctxt hs_inst_ty inst_ty-       ; return inst_ty }--------------------------------------------------- | Type-check a visible type application-tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type--- See Note [Recipe for checking a signature] in TcHsType-tcHsTypeApp wc_ty kind-  | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty-  = do { ty <- solveLocalEqualities "tcHsTypeApp" $-               -- We are looking at a user-written type, very like a-               -- signature so we want to solve its equalities right now-               unsetWOptM Opt_WarnPartialTypeSignatures $-               setXOptM LangExt.PartialTypeSignatures $-               -- See Note [Wildcards in visible type application]-               tcWildCardBinders sig_wcs $ \ _ ->-               tcCheckLHsType hs_ty kind-       -- We must promote here. Ex:-       --   f :: forall a. a-       --   g = f @(forall b. Proxy b -> ()) @Int ...-       -- After when processing the @Int, we'll have to check its kind-       -- against the as-yet-unknown kind of b. This check causes an assertion-       -- failure if we don't promote.-       ; ty <- zonkPromoteType ty-       ; checkValidType TypeAppCtxt ty-       ; return ty }-tcHsTypeApp (XHsWildCardBndrs _) _ = panic "tcHsTypeApp"--{- Note [Wildcards in visible type application]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--A HsWildCardBndrs's hswc_ext now only includes named wildcards, so any unnamed-wildcards stay unchanged in hswc_body and when called in tcHsTypeApp, tcCheckLHsType-will call emitWildCardHoleConstraints on them. However, this would trigger-error/warning when an unnamed wildcard is passed in as a visible type argument,-which we do not want because users should be able to write @_ to skip a instantiating-a type variable variable without fuss. The solution is to switch the-PartialTypeSignatures flags here to let the typechecker know that it's checking-a '@_' and do not emit hole constraints on it.-See related Note [Wildcards in visible kind application]-and Note [The wildcard story for types] in HsTypes.hs---}--{--************************************************************************-*                                                                      *-            The main kind checker: no validity checks here-*                                                                      *-************************************************************************--        First a couple of simple wrappers for kcHsType--}------------------------------tcHsOpenType, tcHsLiftedType,-  tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType--- Used for type signatures--- Do not do validity checking-tcHsOpenType ty   = addTypeCtxt ty $ tcHsOpenTypeNC ty-tcHsLiftedType ty = addTypeCtxt ty $ tcHsLiftedTypeNC ty--tcHsOpenTypeNC   ty = do { ek <- newOpenTypeKind-                         ; tc_lhs_type typeLevelMode ty ek }-tcHsLiftedTypeNC ty = tc_lhs_type typeLevelMode ty liftedTypeKind---- Like tcHsType, but takes an expected kind-tcCheckLHsType :: LHsType GhcRn -> Kind -> TcM TcType-tcCheckLHsType hs_ty exp_kind-  = addTypeCtxt hs_ty $-    tc_lhs_type typeLevelMode hs_ty exp_kind--tcLHsType :: LHsType GhcRn -> TcM (TcType, TcKind)--- Called from outside: set the context-tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type typeLevelMode ty)---- Like tcLHsType, but use it in a context where type synonyms and type families--- do not need to be saturated, like in a GHCi :kind call-tcLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind)-tcLHsTypeUnsaturated ty = addTypeCtxt ty (tc_infer_lhs_type mode ty)-  where-    mode = allowUnsaturated typeLevelMode--{--************************************************************************-*                                                                      *-      Type-checking modes-*                                                                      *-************************************************************************--The kind-checker is parameterised by a TcTyMode, which contains some-information about where we're checking a type.--The renamer issues errors about what it can. All errors issued here must-concern things that the renamer can't handle.---}---- | Do we require type families to be saturated?-data RequireSaturation-  = YesSaturation-  | NoSaturation   -- e.g. during a call to GHCi's :kind---- | Info about the context in which we're checking a type. Currently,--- differentiates only between types and kinds, but this will likely--- grow, at least to include the distinction between patterns and--- not-patterns.-data TcTyMode-  = TcTyMode { mode_level :: TypeOrKind-             , mode_sat   :: RequireSaturation-             }- -- The mode_unsat field is solely so that type families/synonyms can be unsaturated- -- in GHCi :kind calls--typeLevelMode :: TcTyMode-typeLevelMode = TcTyMode { mode_level = TypeLevel, mode_sat = YesSaturation }--kindLevelMode :: TcTyMode-kindLevelMode = TcTyMode { mode_level = KindLevel, mode_sat = YesSaturation }--allowUnsaturated :: TcTyMode -> TcTyMode-allowUnsaturated mode = mode { mode_sat = NoSaturation }---- switch to kind level-kindLevel :: TcTyMode -> TcTyMode-kindLevel mode = mode { mode_level = KindLevel }--instance Outputable RequireSaturation where-  ppr YesSaturation = text "YesSaturation"-  ppr NoSaturation  = text "NoSaturation"--instance Outputable TcTyMode where-  ppr = ppr . mode_level--{--Note [Bidirectional type checking]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In expressions, whenever we see a polymorphic identifier, say `id`, we are-free to instantiate it with metavariables, knowing that we can always-re-generalize with type-lambdas when necessary. For example:--  rank2 :: (forall a. a -> a) -> ()-  x = rank2 id--When checking the body of `x`, we can instantiate `id` with a metavariable.-Then, when we're checking the application of `rank2`, we notice that we really-need a polymorphic `id`, and then re-generalize over the unconstrained-metavariable.--In types, however, we're not so lucky, because *we cannot re-generalize*!-There is no lambda. So, we must be careful only to instantiate at the last-possible moment, when we're sure we're never going to want the lost polymorphism-again. This is done in calls to tcInstTyBinders.--To implement this behavior, we use bidirectional type checking, where we-explicitly think about whether we know the kind of the type we're checking-or not. Note that there is a difference between not knowing a kind and-knowing a metavariable kind: the metavariables are TauTvs, and cannot become-forall-quantified kinds. Previously (before dependent types), there were-no higher-rank kinds, and so we could instantiate early and be sure that-no types would have polymorphic kinds, and so we could always assume that-the kind of a type was a fresh metavariable. Not so anymore, thus the-need for two algorithms.--For HsType forms that can never be kind-polymorphic, we implement only the-"down" direction, where we safely assume a metavariable kind. For HsType forms-that *can* be kind-polymorphic, we implement just the "up" (functions with-"infer" in their name) version, as we gain nothing by also implementing the-"down" version.--Note [Future-proofing the type checker]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As discussed in Note [Bidirectional type checking], each HsType form is-handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions-are mutually recursive, so that either one can work for any type former.-But, we want to make sure that our pattern-matches are complete. So,-we have a bunch of repetitive code just so that we get warnings if we're-missing any patterns.--Note [The tcType invariant]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-(IT1) If    tc_ty = tc_hs_type hs_ty exp_kind-      then  tcTypeKind tc_ty = exp_kind-without any zonking needed.  The reason for this is that in-tcInferApps we see (F ty), and we kind-check 'ty' with an-expected-kind coming from F.  Then, to make the resulting application-well kinded --- see Note [The well-kinded type invariant] in TcType ----we need the kind-checked 'ty' to have exactly the kind that F expects,-with no funny zonking nonsense in between.--The tcType invariant also applies to checkExpectedKind:--(IT2) if-        (tc_ty, _, _) = checkExpectedKind ty act_ki exp_ki-      then-        tcTypeKind tc_ty = exp_ki--These other invariants are all necessary, too, as these functions-are used within tc_hs_type:--(IT3) If (ty, ki) <- tc_infer_hs_type ..., then tcTypeKind ty == ki.--(IT4) If (ty, ki) <- tc_infer_hs_type ..., then zonk ki == ki.-      (In other words, the result kind of tc_infer_hs_type is zonked.)--(IT5) If (ty, ki) <- tcTyVar ..., then tcTypeKind ty == ki.--(IT6) If (ty, ki) <- tcTyVar ..., then zonk ki == ki.-      (In other words, the result kind of tcTyVar is zonked.)---}----------------------------------------------- | Check and desugar a type, returning the core type and its--- possibly-polymorphic kind. Much like 'tcInferRho' at the expression--- level.-tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)-tc_infer_lhs_type mode (L span ty)-  = setSrcSpan span $-    do { (ty', kind) <- tc_infer_hs_type mode ty-       ; return (ty', kind) }---- | Infer the kind of a type and desugar. This is the "up" type-checker,--- as described in Note [Bidirectional type checking]-tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind)-tc_infer_hs_type mode (HsParTy _ t)          = tc_infer_lhs_type mode t-tc_infer_hs_type mode (HsTyVar _ _ (L _ tv)) = tcTyVar mode tv--tc_infer_hs_type mode e@(HsAppTy {}) = tcTyApp mode e-tc_infer_hs_type mode e@(HsAppKindTy {}) = tcTyApp mode e--tc_infer_hs_type mode (HsOpTy _ lhs lhs_op@(L _ hs_op) rhs)-  | not (hs_op `hasKey` funTyConKey)-  = do { (op, op_kind) <- tcTyVar mode hs_op-       ; tcTyApps mode (noLoc $ HsTyVar noExt NotPromoted lhs_op) op op_kind-                       [HsValArg lhs, HsValArg rhs] }--tc_infer_hs_type mode (HsKindSig _ ty sig)-  = do { sig' <- tcLHsKindSig KindSigCtxt sig-                 -- We must typecheck the kind signature, and solve all-                 -- its equalities etc; from this point on we may do-                 -- things like instantiate its foralls, so it needs-                 -- to be fully determined (Trac #14904)-       ; traceTc "tc_infer_hs_type:sig" (ppr ty $$ ppr sig')-       ; ty' <- tc_lhs_type mode ty sig'-       ; return (ty', sig') }---- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType' to communicate--- the splice location to the typechecker. Here we skip over it in order to have--- the same kind inferred for a given expression whether it was produced from--- splices or not.------ See Note [Delaying modFinalizers in untyped splices].-tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)))-  = tc_infer_hs_type mode ty--tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty-tc_infer_hs_type _    (XHsType (NHsCoreTy ty))-  = do { ty <- zonkTcType ty  -- (IT3) and (IT4) of Note [The tcType invariant]-       ; return (ty, tcTypeKind ty) }--tc_infer_hs_type _ (HsExplicitListTy _ _ tys)-  | null tys  -- this is so that we can use visible kind application with '[]-              -- e.g ... '[] @Bool-  = return (mkTyConTy promotedNilDataCon,-            mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy)--tc_infer_hs_type mode other_ty-  = do { kv <- newMetaKindVar-       ; ty' <- tc_hs_type mode other_ty kv-       ; return (ty', kv) }---------------------------------------------tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType-tc_lhs_type mode (L span ty) exp_kind-  = setSrcSpan span $-    tc_hs_type mode ty exp_kind---------------------------------------------tc_fun_type :: TcTyMode -> LHsType GhcRn -> LHsType GhcRn -> TcKind-            -> TcM TcType-tc_fun_type mode ty1 ty2 exp_kind = case mode_level mode of-  TypeLevel ->-    do { arg_k <- newOpenTypeKind-       ; res_k <- newOpenTypeKind-       ; ty1' <- tc_lhs_type mode ty1 arg_k-       ; ty2' <- tc_lhs_type mode ty2 res_k-       ; checkExpectedKindMode mode (ppr $ HsFunTy noExt ty1 ty2) (mkFunTy ty1' ty2')-                           liftedTypeKind exp_kind }-  KindLevel ->  -- no representation polymorphism in kinds. yet.-    do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind-       ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind-       ; checkExpectedKindMode mode (ppr $ HsFunTy noExt ty1 ty2) (mkFunTy ty1' ty2')-                           liftedTypeKind exp_kind }---------------------------------------------tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType--- See Note [The tcType invariant]--- See Note [Bidirectional type checking]--tc_hs_type mode (HsParTy _ ty)   exp_kind = tc_lhs_type mode ty exp_kind-tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind-tc_hs_type _ ty@(HsBangTy _ bang _) _-    -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),-    -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of-    -- bangs are invalid, so fail. (#7210, #14761)-    = do { let bangError err = failWith $-                 text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$-                 text err <+> text "annotation cannot appear nested inside a type"-         ; case bang of-             HsSrcBang _ SrcUnpack _           -> bangError "UNPACK"-             HsSrcBang _ SrcNoUnpack _         -> bangError "NOUNPACK"-             HsSrcBang _ NoSrcUnpack SrcLazy   -> bangError "laziness"-             HsSrcBang _ _ _                   -> bangError "strictness" }-tc_hs_type _ ty@(HsRecTy {})      _-      -- Record types (which only show up temporarily in constructor-      -- signatures) should have been removed by now-    = failWithTc (text "Record syntax is illegal here:" <+> ppr ty)---- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType'.--- Here we get rid of it and add the finalizers to the global environment--- while capturing the local environment.------ See Note [Delaying modFinalizers in untyped splices].-tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty)))-           exp_kind-  = do addModFinalizersWithLclEnv mod_finalizers-       tc_hs_type mode ty exp_kind---- This should never happen; type splices are expanded by the renamer-tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind-  = failWithTc (text "Unexpected type splice:" <+> ppr ty)------------ Functions and applications-tc_hs_type mode (HsFunTy _ ty1 ty2) exp_kind-  = tc_fun_type mode ty1 ty2 exp_kind--tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind-  | op `hasKey` funTyConKey-  = tc_fun_type mode ty1 ty2 exp_kind----------- Foralls-tc_hs_type mode forall@(HsForAllTy { hst_bndrs = hs_tvs, hst_body = ty }) exp_kind-  = do { (tclvl, wanted, (tvs', ty'))-            <- pushLevelAndCaptureConstraints $-               bindExplicitTKBndrs_Skol hs_tvs $-               tc_lhs_type mode ty exp_kind-    -- Do not kind-generalise here!  See Note [Kind generalisation]-    -- Why exp_kind?  See Note [Body kind of HsForAllTy]-       ; let bndrs       = mkTyVarBinders Specified tvs'-             skol_info   = ForAllSkol (ppr forall)-             m_telescope = Just (sep (map ppr hs_tvs))--       ; emitResidualTvConstraint skol_info m_telescope tvs' tclvl wanted--       ; return (mkForAllTys bndrs ty') }--tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind-  | null (unLoc ctxt)-  = tc_lhs_type mode ty exp_kind--  | otherwise-  = do { ctxt' <- tc_hs_context mode ctxt--         -- See Note [Body kind of a HsQualTy]-       ; ty' <- if tcIsConstraintKind exp_kind-                then tc_lhs_type mode ty constraintKind-                else do { ek <- newOpenTypeKind-                                -- The body kind (result of the function)-                                -- can be TYPE r, for any r, hence newOpenTypeKind-                        ; ty' <- tc_lhs_type mode ty ek-                        ; checkExpectedKindMode mode (ppr ty) ty' liftedTypeKind exp_kind }--       ; return (mkPhiTy ctxt' ty') }----------- Lists, arrays, and tuples-tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind-  = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind-       ; checkWiredInTyCon listTyCon-       ; checkExpectedKindMode mode (ppr rn_ty) (mkListTy tau_ty) liftedTypeKind exp_kind }---- See Note [Distinguishing tuple kinds] in HsTypes--- See Note [Inferring tuple kinds]-tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind-     -- (NB: not zonking before looking at exp_k, to avoid left-right bias)-  | Just tup_sort <- tupKindSort_maybe exp_kind-  = traceTc "tc_hs_type tuple" (ppr hs_tys) >>-    tc_tuple rn_ty mode tup_sort hs_tys exp_kind-  | otherwise-  = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys)-       ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys-       ; kinds <- mapM zonkTcType kinds-           -- Infer each arg type separately, because errors can be-           -- confusing if we give them a shared kind.  Eg Trac #7410-           -- (Either Int, Int), we do not want to get an error saying-           -- "the second argument of a tuple should have kind *->*"--       ; let (arg_kind, tup_sort)-               = case [ (k,s) | k <- kinds-                              , Just s <- [tupKindSort_maybe k] ] of-                    ((k,s) : _) -> (k,s)-                    [] -> (liftedTypeKind, BoxedTuple)-         -- In the [] case, it's not clear what the kind is, so guess *--       ; tys' <- sequence [ setSrcSpan loc $-                            checkExpectedKindMode mode (ppr hs_ty) ty kind arg_kind-                          | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ]--       ; finish_tuple rn_ty mode tup_sort tys' (map (const arg_kind) tys') exp_kind }---tc_hs_type mode rn_ty@(HsTupleTy _ hs_tup_sort tys) exp_kind-  = tc_tuple rn_ty mode tup_sort tys exp_kind-  where-    tup_sort = case hs_tup_sort of  -- Fourth case dealt with above-                  HsUnboxedTuple    -> UnboxedTuple-                  HsBoxedTuple      -> BoxedTuple-                  HsConstraintTuple -> ConstraintTuple-                  _                 -> panic "tc_hs_type HsTupleTy"--tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind-  = do { let arity = length hs_tys-       ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys-       ; tau_tys   <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds-       ; let arg_reps = map kindRep arg_kinds-             arg_tys  = arg_reps ++ tau_tys-       ; checkExpectedKindMode mode (ppr rn_ty)-                           (mkTyConApp (sumTyCon arity) arg_tys)-                           (unboxedSumKind arg_reps)-                           exp_kind-       }----------- Promoted lists and tuples-tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind-  = do { tks <- mapM (tc_infer_lhs_type mode) tys-       ; (taus', kind) <- unifyKinds tys tks-       ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus')-       ; checkExpectedKindMode mode (ppr rn_ty) ty (mkListTy kind) exp_kind }-  where-    mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b]-    mk_nil  k     = mkTyConApp (promoteDataCon nilDataCon) [k]--tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind-  -- using newMetaKindVar means that we force instantiations of any polykinded-  -- types. At first, I just used tc_infer_lhs_type, but that led to #11255.-  = do { ks   <- replicateM arity newMetaKindVar-       ; taus <- zipWithM (tc_lhs_type mode) tys ks-       ; let kind_con   = tupleTyCon           Boxed arity-             ty_con     = promotedTupleDataCon Boxed arity-             tup_k      = mkTyConApp kind_con ks-       ; checkExpectedKindMode mode (ppr rn_ty) (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind }-  where-    arity = length tys----------- Constraint types-tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind-  = do { MASSERT( isTypeLevel (mode_level mode) )-       ; ty' <- tc_lhs_type mode ty liftedTypeKind-       ; let n' = mkStrLitTy $ hsIPNameFS n-       ; ipClass <- tcLookupClass ipClassName-       ; checkExpectedKindMode mode (ppr rn_ty) (mkClassPred ipClass [n',ty'])-           constraintKind exp_kind }--tc_hs_type mode rn_ty@(HsStarTy _ _) exp_kind-  -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to-  -- handle it in 'coreView' and 'tcView'.-  = checkExpectedKindMode mode (ppr rn_ty) liftedTypeKind liftedTypeKind exp_kind----------- Literals-tc_hs_type mode rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind-  = do { checkWiredInTyCon typeNatKindCon-       ; checkExpectedKindMode mode (ppr rn_ty) (mkNumLitTy n) typeNatKind exp_kind }--tc_hs_type mode rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind-  = do { checkWiredInTyCon typeSymbolKindCon-       ; checkExpectedKindMode mode (ppr rn_ty) (mkStrLitTy s) typeSymbolKind exp_kind }----------- Potentially kind-polymorphic types: call the "up" checker--- See Note [Future-proofing the type checker]-tc_hs_type mode ty@(HsTyVar {})   ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(HsAppTy {})   ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(HsAppKindTy{}) ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(HsOpTy {})    ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(HsKindSig {}) ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(XHsType (NHsCoreTy{})) ek = tc_infer_hs_type_ek mode ty ek--tc_hs_type mode wc@(HsWildCardTy _) exp_kind-  = do { wc_ty <- tcWildCardOcc mode wc exp_kind-       ; return (mkNakedCastTy wc_ty (mkTcNomReflCo exp_kind))-         -- Take care here! Even though the coercion is Refl,-         -- we still need it to establish Note [The tcType invariant]-       }--tcWildCardOcc :: TcTyMode -> HsType GhcRn -> Kind -> TcM TcType-tcWildCardOcc mode wc exp_kind-  = do { wc_tv <- newWildTyVar-          -- The wildcard's kind should be an un-filled-in meta tyvar-       ; loc <- getSrcSpanM-       ; uniq <- newUnique-       ; let name = mkInternalName uniq (mkTyVarOcc "_") loc-       ; part_tysig <- xoptM LangExt.PartialTypeSignatures-       ; warning <- woptM Opt_WarnPartialTypeSignatures-       -- See Note [Wildcards in visible kind application]-       ; unless (part_tysig && not warning)-             (emitWildCardHoleConstraints [(name,wc_tv)])-       ; checkExpectedKindMode mode (ppr wc) (mkTyVarTy wc_tv)-                           (tyVarKind wc_tv) exp_kind }--{- Note [Wildcards in visible kind application]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There are cases where users might want to pass in a wildcard as a visible kind-argument, for instance:--data T :: forall k1 k2. k1 → k2 → Type where-  MkT :: T a b-x :: T @_ @Nat False n-x = MkT--So we should allow '@_' without emitting any hole constraints, and-regardless of whether PartialTypeSignatures is enabled or not. But how would-the typechecker know which '_' is being used in VKA and which is not when it-calls emitWildCardHoleConstraints in tcHsPartialSigType on all HsWildCardBndrs?-The solution then is to neither rename nor include unnamed wildcards in HsWildCardBndrs,-but instead give every unnamed wildcard a fresh wild tyvar in tcWildCardOcc.-And whenever we see a '@', we automatically turn on PartialTypeSignatures and-turn off hole constraint warnings, and never call emitWildCardHoleConstraints-under these conditions.-See related Note [Wildcards in visible type application] here and-Note [The wildcard story for types] in HsTypes.hs---}------------------------------- | Call 'tc_infer_hs_type' and check its result against an expected kind.-tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType-tc_infer_hs_type_ek mode hs_ty ek-  = do { (ty, k) <- tc_infer_hs_type mode hs_ty-       ; checkExpectedKindMode mode (ppr hs_ty) ty k ek }------------------------------tupKindSort_maybe :: TcKind -> Maybe TupleSort-tupKindSort_maybe k-  | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k'-  | Just k'      <- tcView k            = tupKindSort_maybe k'-  | tcIsConstraintKind k = Just ConstraintTuple-  | tcIsLiftedTypeKind k   = Just BoxedTuple-  | otherwise            = Nothing--tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType-tc_tuple rn_ty mode tup_sort tys exp_kind-  = do { arg_kinds <- case tup_sort of-           BoxedTuple      -> return (nOfThem arity liftedTypeKind)-           UnboxedTuple    -> mapM (\_ -> newOpenTypeKind) tys-           ConstraintTuple -> return (nOfThem arity constraintKind)-       ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds-       ; finish_tuple rn_ty mode tup_sort tau_tys arg_kinds exp_kind }-  where-    arity   = length tys--finish_tuple :: HsType GhcRn-             -> TcTyMode-             -> TupleSort-             -> [TcType]    -- ^ argument types-             -> [TcKind]    -- ^ of these kinds-             -> TcKind      -- ^ expected kind of the whole tuple-             -> TcM TcType-finish_tuple rn_ty mode tup_sort tau_tys tau_kinds exp_kind-  = do { traceTc "finish_tuple" (ppr res_kind $$ ppr tau_kinds $$ ppr exp_kind)-       ; let arg_tys  = case tup_sort of-                   -- See also Note [Unboxed tuple RuntimeRep vars] in TyCon-                 UnboxedTuple    -> tau_reps ++ tau_tys-                 BoxedTuple      -> tau_tys-                 ConstraintTuple -> tau_tys-       ; tycon <- case tup_sort of-           ConstraintTuple-             | arity > mAX_CTUPLE_SIZE-                         -> failWith (bigConstraintTuple arity)-             | otherwise -> tcLookupTyCon (cTupleTyConName arity)-           BoxedTuple    -> do { let tc = tupleTyCon Boxed arity-                               ; checkWiredInTyCon tc-                               ; return tc }-           UnboxedTuple  -> return (tupleTyCon Unboxed arity)-       ; checkExpectedKindMode mode (ppr rn_ty) (mkTyConApp tycon arg_tys) res_kind exp_kind }-  where-    arity = length tau_tys-    tau_reps = map kindRep tau_kinds-    res_kind = case tup_sort of-                 UnboxedTuple    -> unboxedTupleKind tau_reps-                 BoxedTuple      -> liftedTypeKind-                 ConstraintTuple -> constraintKind--bigConstraintTuple :: Arity -> MsgDoc-bigConstraintTuple arity-  = hang (text "Constraint tuple arity too large:" <+> int arity-          <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))-       2 (text "Instead, use a nested tuple")-------------------------------- | Apply a type of a given kind to a list of arguments. This instantiates--- invisible parameters as necessary. Always consumes all the arguments,--- using matchExpectedFunKind as necessary.--- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.---- These kinds should be used to instantiate invisible kind variables;--- they come from an enclosing class for an associated type/data family.-tcInferApps :: TcTyMode-            -> LHsType GhcRn        -- ^ Function (for printing only)-            -> TcType               -- ^ Function-            -> TcKind               -- ^ Function kind (zonked)-            -> [LHsTypeArg GhcRn]   -- ^ Args-            -> TcM (TcType, TcKind) -- ^ (f args, args, result kind)--- Precondition: tcTypeKind fun_ty = fun_ki---    Reason: we will return a type application like (fun_ty arg1 ... argn),---            and that type must be well-kinded---            See Note [The tcType invariant]--- Postcondition: Result kind is zonked.-tcInferApps mode orig_hs_ty fun_ty fun_ki orig_hs_args-  = do { traceTc "tcInferApps {" (ppr orig_hs_ty $$ ppr orig_hs_args $$ ppr fun_ki)-       ; (f_args, res_k) <- go 1 empty_subst fun_ty orig_ki_binders orig_inner_ki orig_hs_args-       ; traceTc "tcInferApps }" empty-       ; res_k <- zonkTcType res_k  -- Uphold (IT4) of Note [The tcType invariant]-       ; return (f_args, res_k) }-  where-    empty_subst                      = mkEmptyTCvSubst $ mkInScopeSet $-                                       tyCoVarsOfType fun_ki-    (orig_ki_binders, orig_inner_ki) = tcSplitPiTys fun_ki--    go :: Int             -- the # of the next argument-       -> TCvSubst        -- instantiating substitution-       -> TcType          -- function applied to some args-       -> [TyBinder]      -- binders in function kind (both vis. and invis.)-       -> TcKind          -- function kind body (not a Pi-type)-       -> [LHsTypeArg GhcRn] -- un-type-checked args-       -> TcM (TcType, TcKind)  -- same as overall return type--      -- no user-written args left. We're done!-    go _ subst fun ki_binders inner_ki []-      = return ( fun-               , nakedSubstTy subst $ mkPiTys ki_binders inner_ki)-                 -- nakedSubstTy: see Note [The well-kinded type invariant]-    go n subst fun all_kindbinder inner_ki (HsArgPar _:args)-      = go n subst fun all_kindbinder inner_ki args-      -- The function's kind has a binder. Is it visible or invisible?-    go n subst fun all_kindbinder@(ki_binder:ki_binders) inner_ki-       all_args@(arg:args)-      | Specified <- tyCoBinderArgFlag ki_binder-      , HsTypeArg _ ki <- arg-         -- Invisible and specified binder with visible kind argument-         = do { traceTc "tcInferApps (vis kind app)" (vcat [ ppr ki_binder, ppr ki-                                                     , ppr (tyBinderType ki_binder)-                                                     , ppr subst, ppr (tyCoBinderArgFlag ki_binder) ])-                  ; let exp_kind = nakedSubstTy subst $ tyBinderType ki_binder-                    -- nakedSubstTy: see Note [The well-kinded type invariant]-                  ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty ki n) $-                            unsetWOptM Opt_WarnPartialTypeSignatures $-                            setXOptM LangExt.PartialTypeSignatures $-                            -- see Note [Wildcards in visible kind application]-                            tc_lhs_type (kindLevel mode) ki exp_kind-                  ; traceTc "tcInferApps (vis kind app)" (ppr exp_kind)-                  ; let subst' = extendTvSubstBinderAndInScope subst ki_binder arg'-                  ; go (n+1) subst'-                       (mkNakedAppTy fun arg')-                       ki_binders inner_ki args }--      | isInvisibleBinder ki_binder-          -- Instantiate if not specified or if there is no kind application-      = do { traceTc "tcInferApps (invis normal app)" (ppr ki_binder $$ ppr subst $$ ppr (tyCoBinderArgFlag ki_binder))-           ; (subst', arg') <- tcInstTyBinder Nothing subst ki_binder-           ; go n subst' (mkNakedAppTy fun arg')-                        ki_binders inner_ki all_args }--      | otherwise -- if binder is visible-         = case arg of-             HsValArg ty -- check the next argument-               -> do { traceTc "tcInferApps (vis normal app)"-                         (vcat [ ppr ki_binder-                               , ppr ty-                               , ppr (tyBinderType ki_binder)-                               , ppr subst ])-                     ; let exp_kind = nakedSubstTy subst $ tyBinderType ki_binder-                     -- nakedSubstTy: see Note [The well-kinded type invariant]-                     ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty ty n) $-                               tc_lhs_type mode ty exp_kind-                     ; traceTc "tcInferApps (vis normal app)" (ppr exp_kind)-                     ; let subst' = extendTvSubstBinderAndInScope subst ki_binder arg'-                     ; go (n+1) subst'-                          (mkNakedAppTy fun arg')-                          ki_binders inner_ki args }-            -- error if the argument is a kind application-             HsTypeArg _ ki -> do { traceTc "tcInferApps (error)"-                                    (vcat [ ppr ki_binder-                                          , ppr ki-                                          , ppr (tyBinderType ki_binder)-                                          , ppr subst-                                          , ppr (isInvisibleBinder ki_binder) ])-                                  ; ty_app_err ki $ nakedSubstTy subst $-                                                  mkPiTys all_kindbinder inner_ki }--             HsArgPar _ -> panic "tcInferApps"  -- handled in separate clause of "go"--       -- We've run out of known binders in the functions's kind.-    go n subst fun [] inner_ki all_args@(arg:args)-      | not (null new_ki_binders)-         -- But, after substituting, we have more binders.-      = go n zapped_subst fun new_ki_binders new_inner_ki all_args--      | otherwise-      = case arg of-        (HsValArg _)-         -- Even after substituting, still no binders. Use matchExpectedFunKind-         -> do { traceTc "tcInferApps (no binder)" (ppr new_inner_ki $$ ppr zapped_subst)-               ; (co, arg_k, res_k) <- matchExpectedFunKind hs_ty substed_inner_ki-               ; let new_in_scope = tyCoVarsOfTypes [arg_k, res_k]-                     subst'       = zapped_subst `extendTCvInScopeSet` new_in_scope-               ; go n subst'-                    (fun `mkNakedCastTy` co)  -- See Note [The well-kinded type invariant]-                    [mkAnonBinder arg_k]-                    res_k all_args }-        (HsTypeArg _ ki) -> ty_app_err ki substed_inner_ki-        (HsArgPar _) -> go n subst fun [] inner_ki args-      where-        substed_inner_ki               = substTy subst inner_ki-        (new_ki_binders, new_inner_ki) = tcSplitPiTys substed_inner_ki-        zapped_subst                   = zapTCvSubst subst-        hs_ty = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args)--    ty_app_err arg ty = failWith $ text "Cannot apply function of kind" <+> quotes (ppr ty)-                           $$ text "to visible kind argument" <+> quotes (ppr arg)--appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn-appTypeToArg f [] = f-appTypeToArg f (HsValArg arg : args) = appTypeToArg (mkHsAppTy f arg) args-appTypeToArg f (HsTypeArg l arg : args)-  = appTypeToArg (mkHsAppKindTy l f arg) args-appTypeToArg f (HsArgPar _ : arg) = appTypeToArg f arg---- | Applies a type to a list of arguments.--- Always consumes all the arguments, using 'matchExpectedFunKind' as--- necessary. If you wish to apply a type to a list of HsTypes, this is--- your function.--- Used for type-checking types only.-tcTyApps :: TcTyMode-         -> LHsType GhcRn        -- ^ Function (for printing only)-         -> TcType               -- ^ Function-         -> TcKind               -- ^ Function kind (zonked)-         -> [LHsTypeArg GhcRn]   -- ^ Args-         -> TcM (TcType, TcKind) -- ^ (f args, result kind)   result kind is zonked--- Precondition: see precondition for tcInferApps-tcTyApps mode orig_hs_ty fun_ty fun_ki args-  = do { (ty', ki') <- tcInferApps mode orig_hs_ty fun_ty fun_ki args-       ; return (ty' `mkNakedCastTy` mkNomReflCo ki', ki') }-          -- The mkNakedCastTy is for (IT3) of Note [The tcType invariant]--tcTyApp :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind) -- only HsAppTy or HsAppKindTy-tcTyApp mode e-  = do { let (hs_fun_ty, hs_args) = splitHsAppTys e-       ; (fun_ty, fun_kind) <- tc_infer_lhs_type mode hs_fun_ty-          -- NB: (IT4) of Note [The tcType invariant] ensures that fun_kind is zonked-       ; tcTyApps mode hs_fun_ty fun_ty fun_kind hs_args }------------------------------ Internally-callable version of checkExpectedKind-checkExpectedKindMode :: HasDebugCallStack-                      => TcTyMode-                      -> SDoc        -- type we're checking-                      -> TcType      -- type we're checking-                      -> TcKind      -- kind of that type-                      -> TcKind      -- expected kind-                      -> TcM TcType-checkExpectedKindMode mode = checkExpectedKind (mode_sat mode)---- | This instantiates invisible arguments for the type being checked if it must--- be saturated and is not yet saturated. It then calls and uses the result--- from checkExpectedKindX to build the final type--- Obeys Note [The tcType invariant]-checkExpectedKind :: HasDebugCallStack-                  => RequireSaturation  -- ^ Do we require all type families to be saturated?-                  -> SDoc           -- ^ type we're checking (for printing)-                  -> TcType         -- ^ type we're checking-                  -> TcKind         -- ^ the known kind of that type-                  -> TcKind         -- ^ the expected kind-                  -> TcM TcType-checkExpectedKind sat hs_ty ty act exp-  = do { (new_ty, new_act) <- case splitTyConApp_maybe ty of-           Just (tc, args)-             -- if the family tycon must be saturated and is not yet satured-             -- If we don't do this, we get #11246-             | YesSaturation <- sat-             , not (mightBeUnsaturatedTyCon tc) && length args < tyConArity tc-             -> do {-                   -- we need to instantiate all invisible arguments up until saturation-                   (tc_args, kind) <- tcInstTyBinders (splitPiTysInvisibleN-                                                        (tyConArity tc - length args)-                                                        act)-                   ; let tc_ty = mkTyConApp tc $ args ++ tc_args-                   ; traceTc "checkExpectedKind:satTyFam" (vcat [ ppr tc <+> dcolon <+> ppr act-                                                   , ppr kind ])-                   ; return (tc_ty, kind) }-           _ -> return (ty, act)-       ; (new_args, co_k) <- checkExpectedKindX hs_ty new_act exp-       ; return (new_ty `mkNakedAppTys` new_args `mkNakedCastTy` co_k) }--checkExpectedKindX :: HasDebugCallStack-                   => SDoc                 -- HsType whose kind we're checking-                   -> TcKind               -- the known kind of that type, k-                   -> TcKind               -- the expected kind, exp_kind-                   -> TcM ([TcType], TcCoercionN)-    -- (the new args, the coercion)--- Instantiate a kind (if necessary) and then call unifyType---      (checkExpectedKind ty act_kind exp_kind)--- checks that the actual kind act_kind is compatible---      with the expected kind exp_kind-checkExpectedKindX pp_hs_ty act_kind exp_kind-  = do { -- We need to make sure that both kinds have the same number of implicit-         -- foralls out front. If the actual kind has more, instantiate accordingly.-         -- Otherwise, just pass the type & kind through: the errors are caught-         -- in unifyType.-         let n_exp_invis_bndrs = invisibleTyBndrCount exp_kind-             n_act_invis_bndrs = invisibleTyBndrCount act_kind-             n_to_inst         = n_act_invis_bndrs - n_exp_invis_bndrs-       ; (new_args, act_kind') <- tcInstTyBinders (splitPiTysInvisibleN n_to_inst act_kind)--       ; let origin = TypeEqOrigin { uo_actual   = act_kind'-                                   , uo_expected = exp_kind-                                   , uo_thing    = Just pp_hs_ty-                                   , uo_visible  = True } -- the hs_ty is visible--       ; traceTc "checkExpectedKindX" $-         vcat [ pp_hs_ty-              , text "act_kind:" <+> ppr act_kind-              , text "act_kind':" <+> ppr act_kind'-              , text "exp_kind:" <+> ppr exp_kind ]--       ; if act_kind' `tcEqType` exp_kind-         then return (new_args, mkTcNomReflCo exp_kind)  -- This is very common-         else do { co_k <- uType KindLevel origin act_kind' exp_kind-                 ; traceTc "checkExpectedKind" (vcat [ ppr act_kind-                                                     , ppr exp_kind-                                                     , ppr co_k ])-                      -- See Note [The tcType invariant]-                ; return (new_args, co_k) } }------------------------------tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]-tcHsMbContext Nothing    = return []-tcHsMbContext (Just cxt) = tcHsContext cxt--tcHsContext :: LHsContext GhcRn -> TcM [PredType]-tcHsContext = tc_hs_context typeLevelMode--tcLHsPredType :: LHsType GhcRn -> TcM PredType-tcLHsPredType = tc_lhs_pred typeLevelMode--tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType]-tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt)--tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType-tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind------------------------------tcTyVar :: TcTyMode -> Name -> TcM (TcType, TcKind)--- See Note [Type checking recursive type and class declarations]--- in TcTyClsDecls-tcTyVar mode name         -- Could be a tyvar, a tycon, or a datacon-  = do { traceTc "lk1" (ppr name)-       ; thing <- tcLookup name-       ; case thing of-           ATyVar _ tv -> -- Important: zonk before returning-                          -- We may have the application ((a::kappa) b)-                          -- where kappa is already unified to (k1 -> k2)-                          -- Then we want to see that arrow.  Best done-                          -- here because we are also maintaining-                          -- Note [The tcType invariant], so we don't just-                          -- want to zonk the kind, leaving the TyVar-                          -- un-zonked  (Trac #14873)-                          do { ty <- zonkTcTyVar tv-                             ; return (ty, tcTypeKind ty) }--           ATcTyCon tc_tc-             -> do { -- See Note [GADT kind self-reference]-                     unless (isTypeLevel (mode_level mode))-                            (promotionErr name TyConPE)-                   ; check_tc tc_tc-                   ; tc_kind <- zonkTcType (tyConKind tc_tc)-                        -- (IT6) of Note [The tcType invariant]-                   ; return (mkTyConTy tc_tc `mkNakedCastTy` mkNomReflCo tc_kind, tc_kind) }-                        -- the mkNakedCastTy ensures (IT5) of Note [The tcType invariant]--           AGlobal (ATyCon tc)-             -> do { check_tc tc-                   ; return (mkTyConTy tc, tyConKind tc) }--           AGlobal (AConLike (RealDataCon dc))-             -> do { data_kinds <- xoptM LangExt.DataKinds-                   ; unless (data_kinds || specialPromotedDc dc) $-                       promotionErr name NoDataKindsDC-                   ; when (isFamInstTyCon (dataConTyCon dc)) $-                       -- see Trac #15245-                       promotionErr name FamDataConPE-                   ; let (_, _, _, theta, _, _) = dataConFullSig dc-                   ; case dc_theta_illegal_constraint theta of-                       Just pred -> promotionErr name $-                                    ConstrainedDataConPE pred-                       Nothing   -> pure ()-                   ; let tc = promoteDataCon dc-                   ; return (mkTyConApp tc [], tyConKind tc) }--           APromotionErr err -> promotionErr name err--           _  -> wrongThingErr "type" thing name }-  where-    check_tc :: TyCon -> TcM ()-    check_tc tc = do { data_kinds   <- xoptM LangExt.DataKinds-                     ; unless (isTypeLevel (mode_level mode) ||-                               data_kinds ||-                               isKindTyCon tc) $-                       promotionErr name NoDataKindsTC }--    -- We cannot promote a data constructor with a context that contains-    -- constraints other than equalities, so error if we find one.-    -- See Note [Constraints handled in types] in Inst.-    dc_theta_illegal_constraint :: ThetaType -> Maybe PredType-    dc_theta_illegal_constraint = find go-      where-        go :: PredType -> Bool-        go pred | Just tc <- tyConAppTyCon_maybe pred-                = not $  tc `hasKey` eqTyConKey-                      || tc `hasKey` heqTyConKey-                | otherwise = True--{--Note [GADT kind self-reference]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--A promoted type cannot be used in the body of that type's declaration.-Trac #11554 shows this example, which made GHC loop:--  import Data.Kind-  data P (x :: k) = Q-  data A :: Type where-    B :: forall (a :: A). P a -> A--In order to check the constructor B, we need to have the promoted type A, but in-order to get that promoted type, B must first be checked. To prevent looping, a-TyConPE promotion error is given when tcTyVar checks an ATcTyCon in kind mode.-Any ATcTyCon is a TyCon being defined in the current recursive group (see data-type decl for TcTyThing), and all such TyCons are illegal in kinds.--Trac #11962 proposes checking the head of a data declaration separately from-its constructors. This would allow the example above to pass.--Note [Body kind of a HsForAllTy]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The body of a forall is usually a type, but in principle-there's no reason to prohibit *unlifted* types.-In fact, GHC can itself construct a function with an-unboxed tuple inside a for-all (via CPR analysis; see-typecheck/should_compile/tc170).--Moreover in instance heads we get forall-types with-kind Constraint.--It's tempting to check that the body kind is either * or #. But this is-wrong. For example:--  class C a b-  newtype N = Mk Foo deriving (C a)--We're doing newtype-deriving for C. But notice how `a` isn't in scope in-the predicate `C a`. So we quantify, yielding `forall a. C a` even though-`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but-convenient. Bottom line: don't check for * or # here.--Note [Body kind of a HsQualTy]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If ctxt is non-empty, the HsQualTy really is a /function/, so the-kind of the result really is '*', and in that case the kind of the-body-type can be lifted or unlifted.--However, consider-    instance Eq a => Eq [a] where ...-or-    f :: (Eq a => Eq [a]) => blah-Here both body-kind of the HsQualTy is Constraint rather than *.-Rather crudely we tell the difference by looking at exp_kind. It's-very convenient to typecheck instance types like any other HsSigType.--Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's-better to reject in checkValidType.  If we say that the body kind-should be '*' we risk getting TWO error messages, one saying that Eq-[a] doens't have kind '*', and one saying that we need a Constraint to-the left of the outer (=>).--How do we figure out the right body kind?  Well, it's a bit of a-kludge: I just look at the expected kind.  If it's Constraint, we-must be in this instance situation context. It's a kludge because it-wouldn't work if any unification was involved to compute that result-kind -- but it isn't.  (The true way might be to use the 'mode'-parameter, but that seemed like a sledgehammer to crack a nut.)--Note [Inferring tuple kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple,-we try to figure out whether it's a tuple of kind * or Constraint.-  Step 1: look at the expected kind-  Step 2: infer argument kinds--If after Step 2 it's not clear from the arguments that it's-Constraint, then it must be *.  Once having decided that we re-check-the Check the arguments again to give good error messages-in eg. `(Maybe, Maybe)`--Note that we will still fail to infer the correct kind in this case:--  type T a = ((a,a), D a)-  type family D :: Constraint -> Constraint--While kind checking T, we do not yet know the kind of D, so we will default the-kind of T to * -> *. It works if we annotate `a` with kind `Constraint`.--Note [Desugaring types]-~~~~~~~~~~~~~~~~~~~~~~~-The type desugarer is phase 2 of dealing with HsTypes.  Specifically:--  * It transforms from HsType to Type--  * It zonks any kinds.  The returned type should have no mutable kind-    or type variables (hence returning Type not TcType):-      - any unconstrained kind variables are defaulted to (Any *) just-        as in TcHsSyn.-      - there are no mutable type variables because we are-        kind-checking a type-    Reason: the returned type may be put in a TyCon or DataCon where-    it will never subsequently be zonked.--You might worry about nested scopes:-        ..a:kappa in scope..-            let f :: forall b. T '[a,b] -> Int-In this case, f's type could have a mutable kind variable kappa in it;-and we might then default it to (Any *) when dealing with f's type-signature.  But we don't expect this to happen because we can't get a-lexically scoped type variable with a mutable kind variable in it.  A-delicate point, this.  If it becomes an issue we might need to-distinguish top-level from nested uses.--Moreover-  * it cannot fail,-  * it does no unifications-  * it does no validity checking, except for structural matters, such as-        (a) spurious ! annotations.-        (b) a class used as a type--Note [Kind of a type splice]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider these terms, each with TH type splice inside:-     [| e1 :: Maybe $(..blah..) |]-     [| e2 :: $(..blah..) |]-When kind-checking the type signature, we'll kind-check the splice-$(..blah..); we want to give it a kind that can fit in any context,-as if $(..blah..) :: forall k. k.--In the e1 example, the context of the splice fixes kappa to *.  But-in the e2 example, we'll desugar the type, zonking the kind unification-variables as we go.  When we encounter the unconstrained kappa, we-want to default it to '*', not to (Any *).--Help functions for type applications-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--}--addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a-        -- Wrap a context around only if we want to show that contexts.-        -- Omit invisible ones and ones user's won't grok-addTypeCtxt (L _ (HsWildCardTy _)) thing = thing   -- "In the type '_'" just isn't helpful.-addTypeCtxt (L _ ty) thing-  = addErrCtxt doc thing-  where-    doc = text "In the type" <+> quotes (ppr ty)--{--************************************************************************-*                                                                      *-                Type-variable binders-%*                                                                      *-%************************************************************************--Note [Dependent LHsQTyVars]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-We track (in the renamer) which explicitly bound variables in a-LHsQTyVars are manifestly dependent; only precisely these variables-may be used within the LHsQTyVars. We must do this so that kcLHsQTyVars-can produce the right TyConBinders, and tell Anon vs. Required.--Example   data T k1 (a:k1) (b:k2) c-               = MkT (Proxy a) (Proxy b) (Proxy c)--Here-  (a:k1),(b:k2),(c:k3)-       are Anon     (explicitly specified as a binder, not used-                     in the kind of any other binder-  k1   is Required  (explicitly specifed as a binder, but used-                     in the kind of another binder i.e. dependently)-  k2   is Specified (not explicitly bound, but used in the kind-                     of another binder)-  k3   in Inferred  (not lexically in scope at all, but inferred-                     by kind inference)-and-  T :: forall {k3} k1. forall k3 -> k1 -> k2 -> k3 -> *--See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility]-in TyCoRep.--kcLHsQTyVars uses the hsq_dependent field to decide whether-k1, a, b, c should be Required or Anon.--Earlier, thought it would work simply to do a free-variable check-during kcLHsQTyVars, but this is bogus, because there may be-unsolved equalities about. And we don't want to eagerly solve the-equalities, because we may get further information after-kcLHsQTyVars is called.  (Recall that kcLHsQTyVars is called-only from getInitialKind.)-This is what implements the rule that all variables intended to be-dependent must be manifestly so.--Sidenote: It's quite possible that later, we'll consider (t -> s)-as a degenerate case of some (pi (x :: t) -> s) and then this will-all get more permissive.--Note [Keeping scoped variables in order: Explicit]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When the user writes `forall a b c. blah`, we bring a, b, and c into-scope and then check blah. In the process of checking blah, we might-learn the kinds of a, b, and c, and these kinds might indicate that-b depends on c, and thus that we should reject the user-written type.--One approach to doing this would be to bring each of a, b, and c into-scope, one at a time, creating an implication constraint and-bumping the TcLevel for each one. This would work, because the kind-of, say, b would be untouchable when c is in scope (and the constraint-couldn't float out because c blocks it). However, it leads to terrible-error messages, complaining about skolem escape. While it is indeed-a problem of skolem escape, we can do better.--Instead, our approach is to bring the block of variables into scope-all at once, creating one implication constraint for the lot. The-user-written variables are skolems in the implication constraint. In-TcSimplify.setImplicationStatus, we check to make sure that the ordering-is correct, choosing ImplicationStatus IC_BadTelescope if they aren't.-Then, in TcErrors, we report if there is a bad telescope. This way,-we can report a suggested ordering to the user if there is a problem.--Note [Keeping scoped variables in order: Implicit]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When the user implicitly quantifies over variables (say, in a type-signature), we need to come up with some ordering on these variables.-This is done by bumping the TcLevel, bringing the tyvars into scope,-and then type-checking the thing_inside. The constraints are all-wrapped in an implication, which is then solved. Finally, we can-zonk all the binders and then order them with scopedSort.--It's critical to solve before zonking and ordering in order to uncover-any unifications. You might worry that this eager solving could cause-trouble elsewhere. I don't think it will. Because it will solve only-in an increased TcLevel, it can't unify anything that was mentioned-elsewhere. Additionally, we require that the order of implicitly-quantified variables is manifest by the scope of these variables, so-we're not going to learn more information later that will help order-these variables.--Note [Recipe for checking a signature]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Checking a user-written signature requires several steps:-- 1. Generate constraints.- 2. Solve constraints.- 3. Zonk.- 4. Promote tyvars and/or kind-generalize.- 5. Zonk.- 6. Check validity.--There may be some surprises in here:--Step 2 is necessary for two reasons: most signatures also bring-implicitly quantified variables into scope, and solving is necessary-to get these in the right order (see Note [Keeping scoped variables in-order: Implicit]). Additionally, solving is necessary in order to-kind-generalize correctly.--In Step 4, we have to deal with the fact that metatyvars generated-in the type may have a bumped TcLevel, because explicit foralls-raise the TcLevel. To avoid these variables from ever being visible-in the surrounding context, we must obey the following dictum:--  Every metavariable in a type must either be-    (A) promoted-    (B) generalized, or-    (C) zapped to Any--If a variable is generalized, then it becomes a skolem and no longer-has a proper TcLevel. (I'm ignoring the TcLevel on a skolem here, as-it's not really in play here.) On the other hand, if it is not-generalized (because we're not generalizing the construct -- e.g., pattern-sig -- or because the metavars are constrained -- see kindGeneralizeLocal)-we need to promote to maintain (MetaTvInv) of Note [TcLevel and untouchable type variables]-in TcType.--For more about (C), see Note [Naughty quantification candidates] in TcMType.--After promoting/generalizing, we need to zonk *again* because both-promoting and generalizing fill in metavariables.--To avoid the double-zonk, we do two things:- 1. When we're not generalizing:-    zonkPromoteType and friends zonk and promote at the same time.-    Accordingly, the function does steps 3-5 all at once, preventing-    the need for multiple traversals.-- 2. When we are generalizing:-    kindGeneralize does not require a zonked type -- it zonks as it-    gathers free variables. So this way effectively sidesteps step 3.--}--tcWildCardBinders :: [Name]-                  -> ([(Name, TcTyVar)] -> TcM a)-                  -> TcM a-tcWildCardBinders wc_names thing_inside-  = do { wcs <- mapM (const newWildTyVar) wc_names-       ; let wc_prs = wc_names `zip` wcs-       ; tcExtendNameTyVarEnv wc_prs $-         thing_inside wc_prs }--newWildTyVar :: TcM TcTyVar--- ^ New unification variable for a wildcard-newWildTyVar-  = do { kind <- newMetaKindVar-       ; uniq <- newUnique-       ; details <- newMetaDetails TauTv-       ; let name = mkSysTvName uniq (fsLit "_")-             tyvar = (mkTcTyVar name kind details)-       ; traceTc "newWildTyVar" (ppr tyvar)-       ; return tyvar }--{- *********************************************************************-*                                                                      *-             Kind inference for type declarations-*                                                                      *-********************************************************************* -}--{- Note [The initial kind of a type constructor]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-kcLHsQTyVars is responsible for getting the initial kind of-a type constructor.--It has two cases:-- * The TyCon has a CUSK.  In that case, find the full, final,-   poly-kinded kind of the TyCon.  It's very like a term-level-   binding where we have a complete type signature for the-   function.-- * It does not have a CUSK.  Find a monomorphic kind, with-   unification variables in it; they will be generalised later.-   It's very like a term-level binding where we do not have-   a type signature (or, more accurately, where we have a-   partial type signature), so we infer the type and generalise.--}------------------------------------ | Kind-check a 'LHsQTyVars'. If the decl under consideration has a complete,--- user-supplied kind signature (CUSK), generalise the result.--- Used in 'getInitialKind' (for tycon kinds and other kinds)--- and in kind-checking (but not for tycon kinds, which are checked with--- tcTyClDecls). See Note [CUSKs: complete user-supplied kind signatures]--- in HsDecls.------ This function does not do telescope checking.-kcLHsQTyVars :: Name              -- ^ of the thing being checked-             -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked-             -> Bool              -- ^ True <=> the decl being checked has a CUSK-             -> LHsQTyVars GhcRn-             -> TcM Kind          -- ^ The result kind-             -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon-kcLHsQTyVars name flav cusk tvs thing_inside-  | cusk      = kcLHsQTyVars_Cusk    name flav tvs thing_inside-  | otherwise = kcLHsQTyVars_NonCusk name flav tvs thing_inside---kcLHsQTyVars_Cusk, kcLHsQTyVars_NonCusk-    :: Name              -- ^ of the thing being checked-    -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked-    -> LHsQTyVars GhcRn-    -> TcM Kind          -- ^ The result kind-    -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon---------------------------------kcLHsQTyVars_Cusk name flav-  user_tyvars@(HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = kv_ns-                                           , hsq_dependent = dep_names }-                      , hsq_explicit = hs_tvs }) thing_inside-  -- CUSK case-  -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls-  = addTyConFlavCtxt name flav $-    do { (scoped_kvs, (tc_tvs, res_kind))-           <- pushTcLevelM_                               $-              solveEqualities                             $-              bindImplicitTKBndrs_Q_Skol kv_ns            $-              bindExplicitTKBndrs_Q_Skol ctxt_kind hs_tvs $-              thing_inside--           -- Now, because we're in a CUSK,-           -- we quantify over the mentioned kind vars-       ; let spec_req_tkvs = scoped_kvs ++ tc_tvs-             all_kinds     = res_kind : map tyVarKind spec_req_tkvs--       ; candidates <- candidateQTyVarsOfKinds all_kinds-             -- 'candidates' are all the variables that we are going to-             -- skolemise and then quantify over.  We do not include spec_req_tvs-             -- because they are /already/ skolems--       ; let inf_candidates = candidates `delCandidates` spec_req_tkvs--       ; inferred <- quantifyTyVars emptyVarSet inf_candidates-                     -- NB: 'inferred' comes back sorted in dependency order--       ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs-       ; tc_tvs     <- mapM zonkTyCoVarKind tc_tvs-       ; res_kind   <- zonkTcType           res_kind--       ; let mentioned_kv_set = candidateKindVars candidates-             specified        = scopedSort scoped_kvs-                                -- NB: maintain the L-R order of scoped_kvs--             final_tc_binders =  mkNamedTyConBinders Inferred  inferred-                              ++ mkNamedTyConBinders Specified specified-                              ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs--             all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)-             tycon = mkTcTyCon name (ppr user_tyvars)-                               final_tc_binders-                               res_kind-                               all_tv_prs-                               True {- it is generalised -} flav-         -- If the ordering from-         -- Note [Required, Specified, and Inferred for types] in TcTyClsDecls-         -- doesn't work, we catch it here, before an error cascade-       ; checkValidTelescope tycon--          -- If any of the specified tyvars aren't actually mentioned in a binder's-          -- kind (or the return kind), then we're in the CUSK case from-          -- Note [Free-floating kind vars]-       ; let unmentioned_kvs   = filterOut (`elemVarSet` mentioned_kv_set) specified-       ; reportFloatingKvs name flav (map binderVar final_tc_binders) unmentioned_kvs---       ; traceTc "kcLHsQTyVars: cusk" $-         vcat [ text "name" <+> ppr name-              , text "kv_ns" <+> ppr kv_ns-              , text "hs_tvs" <+> ppr hs_tvs-              , text "dep_names" <+> ppr dep_names-              , text "scoped_kvs" <+> ppr scoped_kvs-              , text "tc_tvs" <+> ppr tc_tvs-              , text "res_kind" <+> ppr res_kind-              , text "candidates" <+> ppr candidates-              , text "inferred" <+> ppr inferred-              , text "specified" <+> ppr specified-              , text "final_tc_binders" <+> ppr final_tc_binders-              , text "mkTyConKind final_tc_bndrs res_kind"-                <+> ppr (mkTyConKind final_tc_binders res_kind)-              , text "all_tv_prs" <+> ppr all_tv_prs ]--       ; return tycon }-  where-    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind-              | otherwise            = AnyKind--kcLHsQTyVars_Cusk _ _ (XLHsQTyVars _) _ = panic "kcLHsQTyVars"---------------------------------kcLHsQTyVars_NonCusk name flav-  user_tyvars@(HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = kv_ns-                                           , hsq_dependent = dep_names }-                      , hsq_explicit = hs_tvs }) thing_inside-  -- Non_CUSK case-  -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls-  = do { (scoped_kvs, (tc_tvs, res_kind))-           -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar?-           -- See Note [Inferring kinds for type declarations] in TcTyClsDecls-           <- bindImplicitTKBndrs_Q_Tv kv_ns            $-              bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $-              thing_inside-              -- Why "_Tv" not "_Skol"? See third wrinkle in-              -- Note [Inferring kinds for type declarations] in TcTyClsDecls,--       ; let   -- NB: Don't add scoped_kvs to tyConTyVars, because they-               -- might unify with kind vars in other types in a mutually-               -- recursive group.-               -- See Note [Inferring kinds for type declarations] in TcTyClsDecls-             tc_binders = zipWith mk_tc_binder hs_tvs tc_tvs-               -- Also, note that tc_binders has the tyvars from only the-               -- user-written tyvarbinders. See S1 in Note [How TcTyCons work]-               -- in TcTyClsDecls-             tycon = mkTcTyCon name (ppr user_tyvars) tc_binders res_kind-                               (mkTyVarNamePairs (scoped_kvs ++ tc_tvs))-                               False -- not yet generalised-                               flav--       ; traceTc "kcLHsQTyVars: not-cusk" $-         vcat [ ppr name, ppr kv_ns, ppr hs_tvs, ppr dep_names-              , ppr scoped_kvs-              , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ]-       ; return tycon }-  where-    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind-              | otherwise            = AnyKind--    mk_tc_binder :: LHsTyVarBndr GhcRn -> TyVar -> TyConBinder-    -- See Note [Dependent LHsQTyVars]-    mk_tc_binder hs_tv tv-       | hsLTyVarName hs_tv `elemNameSet` dep_names-       = mkNamedTyConBinder Required tv-       | otherwise-       = mkAnonTyConBinder tv--kcLHsQTyVars_NonCusk _ _ (XLHsQTyVars _) _ = panic "kcLHsQTyVars"---{- Note [Kind-checking tyvar binders for associated types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When kind-checking the type-variable binders for associated-   data/newtype decls-   family decls-we behave specially for type variables that are already in scope;-that is, bound by the enclosing class decl.  This is done in-kcLHsQTyVarBndrs:-  * The use of tcImplicitQTKBndrs-  * The tcLookupLocal_maybe code in kc_hs_tv--See Note [Associated type tyvar names] in Class and-    Note [TyVar binders for associated decls] in HsDecls--We must do the same for family instance decls, where the in-scope-variables may be bound by the enclosing class instance decl.-Hence the use of tcImplicitQTKBndrs in tcFamTyPatsAndGen.--Note [Kind variable ordering for associated types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-What should be the kind of `T` in the following example? (#15591)--  class C (a :: Type) where-    type T (x :: f a)--As per Note [Ordering of implicit variables] in RnTypes, we want to quantify-the kind variables in left-to-right order of first occurrence in order to-support visible kind application. But we cannot perform this analysis on just-T alone, since its variable `a` actually occurs /before/ `f` if you consider-the fact that `a` was previously bound by the parent class `C`. That is to say,-the kind of `T` should end up being:--  T :: forall a f. f a -> Type--(It wouldn't necessarily be /wrong/ if the kind ended up being, say,-forall f a. f a -> Type, but that would not be as predictable for users of-visible kind application.)--In contrast, if `T` were redefined to be a top-level type family, like `T2`-below:--  type family T2 (x :: f (a :: Type))--Then `a` first appears /after/ `f`, so the kind of `T2` should be:--  T2 :: forall f a. f a -> Type--In order to make this distinction, we need to know (in kcLHsQTyVars) which-type variables have been bound by the parent class (if there is one). With-the class-bound variables in hand, we can ensure that we always quantify-these first.--}---{- *********************************************************************-*                                                                      *-             Expected kinds-*                                                                      *-********************************************************************* -}---- | Describes the kind expected in a certain context.-data ContextKind = TheKind Kind   -- ^ a specific kind-                 | AnyKind        -- ^ any kind will do-                 | OpenKind       -- ^ something of the form @TYPE _@--------------------------newExpectedKind :: ContextKind -> TcM Kind-newExpectedKind (TheKind k) = return k-newExpectedKind AnyKind     = newMetaKindVar-newExpectedKind OpenKind    = newOpenTypeKind--------------------------expectedKindInCtxt :: UserTypeCtxt -> ContextKind--- Depending on the context, we might accept any kind (for instance, in a TH--- splice), or only certain kinds (like in type signatures).-expectedKindInCtxt (TySynCtxt _)   = AnyKind-expectedKindInCtxt ThBrackCtxt     = AnyKind-expectedKindInCtxt (GhciCtxt {})   = AnyKind--- The types in a 'default' decl can have varying kinds--- See Note [Extended defaults]" in TcEnv-expectedKindInCtxt DefaultDeclCtxt     = AnyKind-expectedKindInCtxt TypeAppCtxt         = AnyKind-expectedKindInCtxt (ForSigCtxt _)      = TheKind liftedTypeKind-expectedKindInCtxt (InstDeclCtxt {})   = TheKind constraintKind-expectedKindInCtxt SpecInstCtxt        = TheKind constraintKind-expectedKindInCtxt _                   = OpenKind---{- *********************************************************************-*                                                                      *-             Bringing type variables into scope-*                                                                      *-********************************************************************* -}------------------------------------------- Implicit binders-----------------------------------------bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv,-  bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv-  :: [Name]-  -> TcM a-  -> TcM ([TcTyVar], a)-bindImplicitTKBndrs_Skol   = bindImplicitTKBndrsX newFlexiKindedSkolemTyVar-bindImplicitTKBndrs_Tv     = bindImplicitTKBndrsX newFlexiKindedTyVarTyVar-bindImplicitTKBndrs_Q_Skol = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedSkolemTyVar)-bindImplicitTKBndrs_Q_Tv   = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedTyVarTyVar)--bindImplicitTKBndrsX :: (Name -> TcM TcTyVar) -- new_tv function-                    -> [Name]-                    -> TcM a-                    -> TcM ([TcTyVar], a)   -- these tyvars are dependency-ordered--- * Guarantees to call solveLocalEqualities to unify---   all constraints from thing_inside.------ * Returned TcTyVars have the supplied HsTyVarBndrs,---   but may be in different order to the original [Name]---   (because of sorting to respect dependency)------ * Returned TcTyVars have zonked kinds---   See Note [Keeping scoped variables in order: Implicit]-bindImplicitTKBndrsX new_tv tv_names thing_inside-  = do { tkvs <- mapM new_tv tv_names-       ; result <- tcExtendTyVarEnv tkvs thing_inside-       ; traceTc "bindImplicitTKBndrs" (ppr tv_names $$ ppr tkvs)-       ; return (tkvs, result) }--newImplicitTyVarQ :: (Name -> TcM TcTyVar) ->  Name -> TcM TcTyVar--- Behave like new_tv, except that if the tyvar is in scope, use it-newImplicitTyVarQ new_tv name-  = do { mb_tv <- tcLookupLcl_maybe name-       ; case mb_tv of-           Just (ATyVar _ tv) -> return tv-           _ -> new_tv name }--newFlexiKindedTyVar :: (Name -> Kind -> TcM TyVar) -> Name -> TcM TyVar-newFlexiKindedTyVar new_tv name-  = do { kind <- newMetaKindVar-       ; new_tv name kind }--newFlexiKindedSkolemTyVar :: Name -> TcM TyVar-newFlexiKindedSkolemTyVar = newFlexiKindedTyVar newSkolemTyVar--newFlexiKindedTyVarTyVar :: Name -> TcM TyVar-newFlexiKindedTyVarTyVar = newFlexiKindedTyVar newTyVarTyVar------------------------------------------- Explicit binders-----------------------------------------bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv-    :: [LHsTyVarBndr GhcRn]-    -> TcM a-    -> TcM ([TcTyVar], a)--bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (tcHsTyVarBndr newSkolemTyVar)-bindExplicitTKBndrs_Tv   = bindExplicitTKBndrsX (tcHsTyVarBndr newTyVarTyVar)--bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv-    :: ContextKind-    -> [LHsTyVarBndr GhcRn]-    -> TcM a-    -> TcM ([TcTyVar], a)--bindExplicitTKBndrs_Q_Skol ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newSkolemTyVar)-bindExplicitTKBndrs_Q_Tv   ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newTyVarTyVar)---- | Used during the "kind-checking" pass in TcTyClsDecls only,--- and even then only for data-con declarations.-bindExplicitTKBndrsX-    :: (HsTyVarBndr GhcRn -> TcM TcTyVar)-    -> [LHsTyVarBndr GhcRn]-    -> TcM a-    -> TcM ([TcTyVar], a)-bindExplicitTKBndrsX tc_tv hs_tvs thing_inside-  = do { traceTc "bindExplicTKBndrs" (ppr hs_tvs)-       ; go hs_tvs }-  where-    go [] = do { res <- thing_inside-               ; return ([], res) }-    go (L _ hs_tv : hs_tvs)-       = do { tv <- tc_tv hs_tv-            ; (tvs, res) <- tcExtendTyVarEnv [tv] (go hs_tvs)-            ; return (tv:tvs, res) }--------------------tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar)-              -> HsTyVarBndr GhcRn -> TcM TcTyVar--- Returned TcTyVar has the same name; no cloning-tcHsTyVarBndr new_tv (UserTyVar _ (L _ tv_nm))-  = do { kind <- newMetaKindVar-       ; new_tv tv_nm kind }-tcHsTyVarBndr new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind)-  = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind-       ; new_tv tv_nm kind }-tcHsTyVarBndr _ (XTyVarBndr _) = panic "tcHsTyVarBndr"--------------------tcHsQTyVarBndr :: ContextKind-               -> (Name -> Kind -> TcM TyVar)-               -> HsTyVarBndr GhcRn -> TcM TcTyVar--- Just like tcHsTyVarBndr, but also---   - uses the in-scope TyVar from class, if it exists---   - takes a ContextKind to use for the no-sig case-tcHsQTyVarBndr ctxt_kind new_tv (UserTyVar _ (L _ tv_nm))-  = do { mb_tv <- tcLookupLcl_maybe tv_nm-       ; case mb_tv of-           Just (ATyVar _ tv) -> return tv-           _ -> do { kind <- newExpectedKind ctxt_kind-                   ; new_tv tv_nm kind } }--tcHsQTyVarBndr _ new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind)-  = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind-       ; mb_tv <- tcLookupLcl_maybe tv_nm-       ; case mb_tv of-           Just (ATyVar _ tv)-             -> do { discardResult $ unifyKind (Just hs_tv)-                                        kind (tyVarKind tv)-                       -- This unify rejects:-                       --    class C (m :: * -> *) where-                       --      type F (m :: *) = ...-                   ; return tv }--           _ -> new_tv tv_nm kind }-  where-    hs_tv = HsTyVar noExt NotPromoted (noLoc tv_nm)-            -- Used for error messages only--tcHsQTyVarBndr _ _ (XTyVarBndr _) = panic "tcHsTyVarBndr"-------------------------------------------- Binding type/class variables in the--- kind-checking and typechecking phases-----------------------------------------bindTyClTyVars :: Name-               -> ([TyConBinder] -> Kind -> TcM a) -> TcM a--- ^ Used for the type variables of a type or class decl--- in the "kind checking" and "type checking" pass,--- but not in the initial-kind run.-bindTyClTyVars tycon_name thing_inside-  = do { tycon <- kcLookupTcTyCon tycon_name-       ; let scoped_prs = tcTyConScopedTyVars tycon-             res_kind   = tyConResKind tycon-             binders    = tyConBinders tycon-       ; traceTc "bindTyClTyVars" (ppr tycon_name <+> ppr binders)-       ; tcExtendNameTyVarEnv scoped_prs $-         thing_inside binders res_kind }---- getInitialKind has made a suitably-shaped kind for the type or class--- Look it up in the local environment. This is used only for tycons--- that we're currently type-checking, so we're sure to find a TcTyCon.-kcLookupTcTyCon :: Name -> TcM TcTyCon-kcLookupTcTyCon nm-  = do { tc_ty_thing <- tcLookup nm-       ; return $ case tc_ty_thing of-           ATcTyCon tc -> tc-           _           -> pprPanic "kcLookupTcTyCon" (ppr tc_ty_thing) }---{- *********************************************************************-*                                                                      *-             Kind generalisation-*                                                                      *-********************************************************************* -}--zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar]-zonkAndScopedSort spec_tkvs-  = do { spec_tkvs <- mapM zonkTcTyCoVarBndr spec_tkvs-          -- Use zonkTcTyCoVarBndr because a skol_tv might be a TyVarTv--       -- Do a stable topological sort, following-       -- Note [Ordering of implicit variables] in RnTypes-       ; return (scopedSort spec_tkvs) }--kindGeneralize :: TcType -> TcM [KindVar]--- Quantify the free kind variables of a kind or type--- In the latter case the type is closed, so it has no free--- type variables.  So in both cases, all the free vars are kind vars--- Input needn't be zonked. All variables to be quantified must--- have a TcLevel higher than the ambient TcLevel.--- NB: You must call solveEqualities or solveLocalEqualities before--- kind generalization------ NB: this function is just a specialised version of---        kindGeneralizeLocal emptyWC kind_or_type----kindGeneralize kind_or_type-  = do { kt <- zonkTcType kind_or_type-       ; traceTc "kindGeneralise1" (ppr kt)-       ; dvs <- candidateQTyVarsOfKind kind_or_type-       ; gbl_tvs <- tcGetGlobalTyCoVars -- Already zonked-       ; traceTc "kindGeneralize" (vcat [ ppr kind_or_type-                                        , ppr dvs ])-       ; quantifyTyVars gbl_tvs dvs }---- | This variant of 'kindGeneralize' refuses to generalize over any--- variables free in the given WantedConstraints. Instead, it promotes--- these variables into an outer TcLevel. All variables to be quantified must--- have a TcLevel higher than the ambient TcLevel. See also--- Note [Promoting unification variables] in TcSimplify-kindGeneralizeLocal :: WantedConstraints -> TcType -> TcM [KindVar]-kindGeneralizeLocal wanted kind_or_type-  = do {-       -- This bit is very much like decideMonoTyVars in TcSimplify,-       -- but constraints are so much simpler in kinds, it is much-       -- easier here. (In particular, we never quantify over a-       -- constraint in a type.)-       ; constrained <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted)-       ; (_, constrained) <- promoteTyVarSet constrained--       ; gbl_tvs <- tcGetGlobalTyCoVars -- Already zonked-       ; let mono_tvs = gbl_tvs `unionVarSet` constrained--         -- use the "Kind" variant here, as any types we see-         -- here will already have all type variables quantified;-         -- thus, every free variable is really a kv, never a tv.-       ; dvs <- candidateQTyVarsOfKind kind_or_type--       ; traceTc "kindGeneralizeLocal" $-         vcat [ text "Wanted:" <+> ppr wanted-              , text "Kind or type:" <+> ppr kind_or_type-              , text "tcvs of wanted:" <+> pprTyVars (nonDetEltsUniqSet (tyCoVarsOfWC wanted))-              , text "constrained:" <+> pprTyVars (nonDetEltsUniqSet constrained)-              , text "mono_tvs:" <+> pprTyVars (nonDetEltsUniqSet mono_tvs)-              , text "dvs:" <+> ppr dvs ]--       ; quantifyTyVars mono_tvs dvs }--{- Note [Levels and generalisation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  f x = e-with no type signature. We are currently at level i.-We must-  * Push the level to level (i+1)-  * Allocate a fresh alpha[i+1] for the result type-  * Check that e :: alpha[i+1], gathering constraint WC-  * Solve WC as far as possible-  * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i]-  * Find the free variables with level > i, in this case gamma[i]-  * Skolemise those free variables and quantify over them, giving-       f :: forall g. beta[i-1] -> g-  * Emit the residiual constraint wrapped in an implication for g,-    thus   forall g. WC--All of this happens for types too.  Consider-  f :: Int -> (forall a. Proxy a -> Int)--Note [Kind generalisation]-~~~~~~~~~~~~~~~~~~~~~~~~~~-We do kind generalisation only at the outer level of a type signature.-For example, consider-  T :: forall k. k -> *-  f :: (forall a. T a -> Int) -> Int-When kind-checking f's type signature we generalise the kind at-the outermost level, thus:-  f1 :: forall k. (forall (a:k). T k a -> Int) -> Int  -- YES!-and *not* at the inner forall:-  f2 :: (forall k. forall (a:k). T k a -> Int) -> Int  -- NO!-Reason: same as for HM inference on value level declarations,-we want to infer the most general type.  The f2 type signature-would be *less applicable* than f1, because it requires a more-polymorphic argument.--NB: There are no explicit kind variables written in f's signature.-When there are, the renamer adds these kind variables to the list of-variables bound by the forall, so you can indeed have a type that's-higher-rank in its kind. But only by explicit request.--Note [Kinds of quantified type variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-tcTyVarBndrsGen quantifies over a specified list of type variables,-*and* over the kind variables mentioned in the kinds of those tyvars.--Note that we must zonk those kinds (obviously) but less obviously, we-must return type variables whose kinds are zonked too. Example-    (a :: k7)  where  k7 := k9 -> k9-We must return-    [k9, a:k9->k9]-and NOT-    [k9, a:k7]-Reason: we're going to turn this into a for-all type,-   forall k9. forall (a:k7). blah-which the type checker will then instantiate, and instantiate does not-look through unification variables!--Hence using zonked_kinds when forming tvs'.---}--------------------------------------etaExpandAlgTyCon :: [TyConBinder]-                  -> Kind-                  -> TcM ([TyConBinder], Kind)--- GADT decls can have a (perhaps partial) kind signature---      e.g.  data T a :: * -> * -> * where ...--- This function makes up suitable (kinded) TyConBinders for the--- argument kinds.  E.g. in this case it might return---   ([b::*, c::*], *)--- Never emits constraints.--- It's a little trickier than you might think: see--- Note [TyConBinders for the result kind signature of a data type]-etaExpandAlgTyCon tc_bndrs kind-  = do  { loc     <- getSrcSpanM-        ; uniqs   <- newUniqueSupply-        ; rdr_env <- getLocalRdrEnv-        ; let new_occs = [ occ-                         | str <- allNameStrings-                         , let occ = mkOccName tvName str-                         , isNothing (lookupLocalRdrOcc rdr_env occ)-                         -- Note [Avoid name clashes for associated data types]-                         , not (occ `elem` lhs_occs) ]-              new_uniqs = uniqsFromSupply uniqs-              subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet lhs_tvs))-        ; return (go loc new_occs new_uniqs subst [] kind) }-  where-    lhs_tvs  = map binderVar tc_bndrs-    lhs_occs = map getOccName lhs_tvs--    go loc occs uniqs subst acc kind-      = case splitPiTy_maybe kind of-          Nothing -> (reverse acc, substTy subst kind)--          Just (Anon arg, kind')-            -> go loc occs' uniqs' subst' (tcb : acc) kind'-            where-              arg'   = substTy subst arg-              tv     = mkTyVar (mkInternalName uniq occ loc) arg'-              subst' = extendTCvInScope subst tv-              tcb    = Bndr tv AnonTCB-              (uniq:uniqs') = uniqs-              (occ:occs')   = occs--          Just (Named (Bndr tv vis), kind')-            -> go loc occs uniqs subst' (tcb : acc) kind'-            where-              (subst', tv') = substTyVarBndr subst tv-              tcb = Bndr tv' (NamedTCB vis)--badKindSig :: Bool -> Kind -> SDoc-badKindSig check_for_type kind- = hang (sep [ text "Kind signature on data type declaration has non-*"-             , (if check_for_type then empty else text "and non-variable") <+>-               text "return kind" ])-        2 (ppr kind)--tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis]--- Result is in 1-1 correpondence with orig_args-tcbVisibilities tc orig_args-  = go (tyConKind tc) init_subst orig_args-  where-    init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes orig_args))-    go _ _ []-      = []--    go fun_kind subst all_args@(arg : args)-      | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind-      = case tcb of-          Anon _              -> AnonTCB      : go inner_kind subst  args-          Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args-                 where-                    subst' = extendTCvSubst subst tv arg--      | not (isEmptyTCvSubst subst)-      = go (substTy subst fun_kind) init_subst all_args--      | otherwise-      = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args)---{- Note [TyConBinders for the result kind signature of a data type]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Given-  data T (a::*) :: * -> forall k. k -> *-we want to generate the extra TyConBinders for T, so we finally get-  (a::*) (b::*) (k::*) (c::k)-The function etaExpandAlgTyCon generates these extra TyConBinders from-the result kind signature.--We need to take care to give the TyConBinders-  (a) OccNames that are fresh (because the TyConBinders of a TyCon-      must have distinct OccNames--  (b) Uniques that are fresh (obviously)--For (a) we need to avoid clashes with the tyvars declared by-the user before the "::"; in the above example that is 'a'.-And also see Note [Avoid name clashes for associated data types].--For (b) suppose we have-   data T :: forall k. k -> forall k. k -> *-where the two k's are identical even up to their uniques.  Surprisingly,-this can happen: see Trac #14515.--It's reasonably easy to solve all this; just run down the list with a-substitution; hence the recursive 'go' function.  But it has to be-done.--Note [Avoid name clashes for associated data types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider    class C a b where-               data D b :: * -> *-When typechecking the decl for D, we'll invent an extra type variable-for D, to fill out its kind.  Ideally we don't want this type variable-to be 'a', because when pretty printing we'll get-            class C a b where-               data D b a0-(NB: the tidying happens in the conversion to IfaceSyn, which happens-as part of pretty-printing a TyThing.)--That's why we look in the LocalRdrEnv to see what's in scope. This is-important only to get nice-looking output when doing ":info C" in GHCi.-It isn't essential for correctness.---************************************************************************-*                                                                      *-             Partial signatures-*                                                                      *-************************************************************************---}--tcHsPartialSigType-  :: UserTypeCtxt-  -> LHsSigWcType GhcRn       -- The type signature-  -> TcM ( [(Name, TcTyVar)]  -- Wildcards-         , Maybe TcType       -- Extra-constraints wildcard-         , [Name]             -- Original tyvar names, in correspondence with ...-         , [TcTyVar]          -- ... Implicitly and explicitly bound type variables-         , TcThetaType        -- Theta part-         , TcType )           -- Tau part--- See Note [Recipe for checking a signature]-tcHsPartialSigType ctxt sig_ty-  | HsWC { hswc_ext  = sig_wcs,         hswc_body = ib_ty } <- sig_ty-  , HsIB { hsib_ext = implicit_hs_tvs-         , hsib_body = hs_ty } <- ib_ty-  , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTy hs_ty-  = addSigCtxt ctxt hs_ty $-    do { (implicit_tvs, (explicit_tvs, (wcs, wcx, theta, tau)))-            <- tcWildCardBinders sig_wcs $ \ wcs ->-               bindImplicitTKBndrs_Tv implicit_hs_tvs       $-               bindExplicitTKBndrs_Tv explicit_hs_tvs       $-               do {   -- Instantiate the type-class context; but if there-                      -- is an extra-constraints wildcard, just discard it here-                    (theta, wcx) <- tcPartialContext hs_ctxt--                  ; tau <- tcHsOpenType hs_tau--                  ; return (wcs, wcx, theta, tau) }--         -- We must return these separately, because all the zonking below-         -- might change the name of a TyVarTv. This, in turn, causes trouble-         -- in partial type signatures that bind scoped type variables, as-         -- we bring the wrong name into scope in the function body.-         -- Test case: partial-sigs/should_compile/LocalDefinitionBug-       ; let tv_names = map tyVarName (implicit_tvs ++ explicit_tvs)--       -- Spit out the wildcards (including the extra-constraints one)-       -- as "hole" constraints, so that they'll be reported if necessary-       -- See Note [Extra-constraint holes in partial type signatures]-       ; emitWildCardHoleConstraints wcs--         -- The TyVarTvs created above will sometimes have too high a TcLevel-         -- (note that they are generated *after* bumping the level in-         -- the tc{Im,Ex}plicitTKBndrsSig functions. Bumping the level-         -- is still important here, because the kinds of these variables-         -- do indeed need to have the higher level, so they can unify-         -- with other local type variables. But, now that we've type-checked-         -- everything (and solved equalities in the tcImplicit call)-         -- we need to promote the TyVarTvs so we don't violate the TcLevel-         -- invariant-       ; implicit_tvs <- zonkAndScopedSort implicit_tvs-       ; explicit_tvs <- mapM zonkTcTyCoVarBndr explicit_tvs-       ; theta        <- mapM zonkTcType theta-       ; tau          <- zonkTcType tau--       ; let all_tvs = implicit_tvs ++ explicit_tvs--       ; checkValidType ctxt (mkSpecForAllTys all_tvs $ mkPhiTy theta tau)--       ; traceTc "tcHsPartialSigType" (ppr all_tvs)-       ; return (wcs, wcx, tv_names, all_tvs, theta, tau) }--tcHsPartialSigType _ (HsWC _ (XHsImplicitBndrs _)) = panic "tcHsPartialSigType"-tcHsPartialSigType _ (XHsWildCardBndrs _) = panic "tcHsPartialSigType"--tcPartialContext :: HsContext GhcRn -> TcM (TcThetaType, Maybe TcType)-tcPartialContext hs_theta-  | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta-  , L _ wc@(HsWildCardTy _) <- ignoreParens hs_ctxt_last-  = do { wc_tv_ty <- tcWildCardOcc typeLevelMode wc constraintKind-       ; theta <- mapM tcLHsPredType hs_theta1-       ; return (theta, Just wc_tv_ty) }-  | otherwise-  = do { theta <- mapM tcLHsPredType hs_theta-       ; return (theta, Nothing) }--{- Note [Extra-constraint holes in partial type signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  f :: (_) => a -> a-  f x = ...--* The renamer leaves '_' untouched.--* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in-  tcWildCardBinders.--* TcBinds.chooseInferredQuantifiers fills in that hole TcTyVar-  with the inferred constraints, e.g. (Eq a, Show a)--* TcErrors.mkHoleError finally reports the error.--An annoying difficulty happens if there are more than 62 inferred-constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple.-Where do we find the TyCon?  For good reasons we only have constraint-tuples up to 62 (see Note [How tuples work] in TysWiredIn).  So how-can we make a 70-tuple?  This was the root cause of Trac #14217.--It's incredibly tiresome, because we only need this type to fill-in the hole, to communicate to the error reporting machinery.  Nothing-more.  So I use a HACK:--* I make an /ordinary/ tuple of the constraints, in-  TcBinds.chooseInferredQuantifiers. This is ill-kinded because-  ordinary tuples can't contain constraints, but it works fine. And for-  ordinary tuples we don't have the same limit as for constraint-  tuples (which need selectors and an assocated class).--* Because it is ill-kinded, it trips an assert in writeMetaTyVar,-  so now I disable the assertion if we are writing a type of-  kind Constraint.  (That seldom/never normally happens so we aren't-  losing much.)--Result works fine, but it may eventually bite us.---************************************************************************-*                                                                      *-      Pattern signatures (i.e signatures that occur in patterns)-*                                                                      *-********************************************************************* -}--tcHsPatSigType :: UserTypeCtxt-               -> LHsSigWcType GhcRn          -- The type signature-               -> TcM ( [(Name, TcTyVar)]     -- Wildcards-                      , [(Name, TcTyVar)]     -- The new bit of type environment, binding-                                              -- the scoped type variables-                      , TcType)       -- The type--- Used for type-checking type signatures in--- (a) patterns           e.g  f (x::Int) = e--- (b) RULE forall bndrs  e.g. forall (x::Int). f x = x------ This may emit constraints--- See Note [Recipe for checking a signature]-tcHsPatSigType ctxt sig_ty-  | HsWC { hswc_ext = sig_wcs,   hswc_body = ib_ty } <- sig_ty-  , HsIB { hsib_ext = sig_vars-         , hsib_body = hs_ty } <- ib_ty-  = addSigCtxt ctxt hs_ty $-    do { sig_tkvs <- mapM new_implicit_tv sig_vars-       ; (wcs, sig_ty)-            <- solveLocalEqualities "tcHsPatSigType" $-                 -- Always solve local equalities if possible,-                 -- else casts get in the way of deep skolemisation-                 -- (Trac #16033)-               tcWildCardBinders sig_wcs  $ \ wcs ->-               tcExtendTyVarEnv sig_tkvs                           $-               do { sig_ty <- tcHsOpenType hs_ty-                  ; return (wcs, sig_ty) }--        ; emitWildCardHoleConstraints wcs--          -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty-          -- contains a forall). Promote these.-          -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ...-          -- When we instantiate x, we have to compare the kind of the argument-          -- to a's kind, which will be a metavariable.-        ; sig_ty <- zonkPromoteType sig_ty-        ; checkValidType ctxt sig_ty--        ; let tv_pairs = mkTyVarNamePairs sig_tkvs--        ; traceTc "tcHsPatSigType" (ppr sig_vars)-        ; return (wcs, tv_pairs, sig_ty) }-  where-    new_implicit_tv name = do { kind <- newMetaKindVar-                              ; new_tv name kind }--    new_tv = case ctxt of-               RuleSigCtxt {} -> newSkolemTyVar-               _              -> newTauTyVar-      -- See Note [Pattern signature binders]---tcHsPatSigType _ (HsWC _ (XHsImplicitBndrs _)) = panic "tcHsPatSigType"-tcHsPatSigType _ (XHsWildCardBndrs _)          = panic "tcHsPatSigType"--tcPatSig :: Bool                    -- True <=> pattern binding-         -> LHsSigWcType GhcRn-         -> ExpSigmaType-         -> TcM (TcType,            -- The type to use for "inside" the signature-                 [(Name,TcTyVar)],  -- The new bit of type environment, binding-                                    -- the scoped type variables-                 [(Name,TcTyVar)],  -- The wildcards-                 HsWrapper)         -- Coercion due to unification with actual ty-                                    -- Of shape:  res_ty ~ sig_ty-tcPatSig in_pat_bind sig res_ty- = do  { (sig_wcs, sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt sig-        -- sig_tvs are the type variables free in 'sig',-        -- and not already in scope. These are the ones-        -- that should be brought into scope--        ; if null sig_tvs then do {-                -- Just do the subsumption check and return-                  wrap <- addErrCtxtM (mk_msg sig_ty) $-                          tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty-                ; return (sig_ty, [], sig_wcs, wrap)-        } else do-                -- Type signature binds at least one scoped type variable--                -- A pattern binding cannot bind scoped type variables-                -- It is more convenient to make the test here-                -- than in the renamer-        { when in_pat_bind (addErr (patBindSigErr sig_tvs))--                -- Check that all newly-in-scope tyvars are in fact-                -- constrained by the pattern.  This catches tiresome-                -- cases like-                --      type T a = Int-                --      f :: Int -> Int-                --      f (x :: T a) = ...-                -- Here 'a' doesn't get a binding.  Sigh-        ; let bad_tvs = filterOut (`elemVarSet` exactTyCoVarsOfType sig_ty)-                                  (tyCoVarsOfTypeList sig_ty)-        ; checkTc (null bad_tvs) (badPatTyVarTvs sig_ty bad_tvs)--        -- Now do a subsumption check of the pattern signature against res_ty-        ; wrap <- addErrCtxtM (mk_msg sig_ty) $-                  tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty--        -- Phew!-        ; return (sig_ty, sig_tvs, sig_wcs, wrap)-        } }-  where-    mk_msg sig_ty tidy_env-       = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty-            ; res_ty <- readExpType res_ty   -- should be filled in by now-            ; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty-            ; let msg = vcat [ hang (text "When checking that the pattern signature:")-                                  4 (ppr sig_ty)-                             , nest 2 (hang (text "fits the type of its context:")-                                          2 (ppr res_ty)) ]-            ; return (tidy_env, msg) }--patBindSigErr :: [(Name,TcTyVar)] -> SDoc-patBindSigErr sig_tvs-  = hang (text "You cannot bind scoped type variable" <> plural sig_tvs-          <+> pprQuotedList (map fst sig_tvs))-       2 (text "in a pattern binding signature")--{- Note [Pattern signature binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also Note [Type variables in the type environment] in TcRnTypes.-Consider--  data T where-    MkT :: forall a. a -> (a -> Int) -> T--  f :: T -> ...-  f (MkT x (f :: b -> c)) = <blah>--Here- * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk',-   It must be a skolem so that that it retains its identity, and-   TcErrors.getSkolemInfo can thereby find the binding site for the skolem.-- * The type signature pattern (f :: b -> c) makes freshs meta-tyvars-   beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the-   environment-- * Then unification makes beta := a_sk, gamma := Int-   That's why we must make beta and gamma a MetaTv,-   not a SkolemTv, so that it can unify to a_sk (or Int, respectively).-- * Finally, in '<blah>' we have the envt "b" :-> beta, "c" :-> gamma,-   so we return the pairs ("b" :-> beta, "c" :-> gamma) from tcHsPatSigType,--Another example (Trac #13881):-   fl :: forall (l :: [a]). Sing l -> Sing l-   fl (SNil :: Sing (l :: [y])) = SNil-When we reach the pattern signature, 'l' is in scope from the-outer 'forall':-   "a" :-> a_sk :: *-   "l" :-> l_sk :: [a_sk]-We make up a fresh meta-TauTv, y_sig, for 'y', and kind-check-the pattern signature-   Sing (l :: [y])-That unifies y_sig := a_sk.  We return from tcHsPatSigType with-the pair ("y" :-> y_sig).--For RULE binders, though, things are a bit different (yuk).-  RULE "foo" forall (x::a) (y::[a]).  f x y = ...-Here this really is the binding site of the type variable so we'd like-to use a skolem, so that we get a complaint if we unify two of them-together.  Hence the new_tv function in tcHsPatSigType.---************************************************************************-*                                                                      *-        Checking kinds-*                                                                      *-************************************************************************---}--unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind)-unifyKinds rn_tys act_kinds-  = do { kind <- newMetaKindVar-       ; let check rn_ty (ty, act_kind) = checkExpectedKind YesSaturation (ppr $ unLoc rn_ty) ty act_kind kind-       ; tys' <- zipWithM check rn_tys act_kinds-       ; return (tys', kind) }--{--************************************************************************-*                                                                      *-    Promotion-*                                                                      *-************************************************************************--}---- | Whenever a type is about to be added to the environment, it's necessary--- to make sure that any free meta-tyvars in the type are promoted to the--- current TcLevel. (They might be at a higher level due to the level-bumping--- in tcExplicitTKBndrs, for example.) This function both zonks *and*--- promotes. Why at the same time? See Note [Recipe for checking a signature]-zonkPromoteType :: TcType -> TcM TcType-zonkPromoteType = mapType zonkPromoteMapper ()---- cf. TcMType.zonkTcTypeMapper-zonkPromoteMapper :: TyCoMapper () TcM-zonkPromoteMapper = TyCoMapper { tcm_smart    = True-                               , tcm_tyvar    = const zonkPromoteTcTyVar-                               , tcm_covar    = const covar-                               , tcm_hole     = const hole-                               , tcm_tycobinder = const tybinder-                               , tcm_tycon    = return }-  where-    covar cv-      = mkCoVarCo <$> zonkPromoteTyCoVarKind cv--    hole :: CoercionHole -> TcM Coercion-    hole h-      = do { contents <- unpackCoercionHole_maybe h-           ; case contents of-               Just co -> do { co <- zonkPromoteCoercion co-                             ; checkCoercionHole cv co }-               Nothing -> do { cv' <- zonkPromoteTyCoVarKind cv-                             ; return $ mkHoleCo (setCoHoleCoVar h cv') } }-      where-        cv = coHoleCoVar h--    tybinder :: TyVar -> ArgFlag -> TcM ((), TyVar)-    tybinder tv _flag = ((), ) <$> zonkPromoteTyCoVarKind tv--zonkPromoteTcTyVar :: TyCoVar -> TcM TcType-zonkPromoteTcTyVar tv-  | isMetaTyVar tv-  = do { let ref = metaTyVarRef tv-       ; contents <- readTcRef ref-       ; case contents of-           Flexi -> do { (_, promoted_tv) <- promoteTyVar tv-                       ; mkTyVarTy <$> zonkPromoteTyCoVarKind promoted_tv }-           Indirect ty -> zonkPromoteType ty }--  | isTcTyVar tv && isSkolemTyVar tv  -- NB: isSkolemTyVar says "True" to pure TyVars-  = do { tc_lvl <- getTcLevel-       ; mkTyVarTy <$> zonkPromoteTyCoVarKind (promoteSkolem tc_lvl tv) }--  | otherwise-  = mkTyVarTy <$> zonkPromoteTyCoVarKind tv--zonkPromoteTyCoVarKind :: TyCoVar -> TcM TyCoVar-zonkPromoteTyCoVarKind = updateTyVarKindM zonkPromoteType--zonkPromoteCoercion :: Coercion -> TcM Coercion-zonkPromoteCoercion = mapCoercion zonkPromoteMapper ()--{--************************************************************************-*                                                                      *-        Sort checking kinds-*                                                                      *-************************************************************************--tcLHsKindSig converts a user-written kind to an internal, sort-checked kind.-It does sort checking and desugaring at the same time, in one single pass.--}--tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind-tcLHsKindSig ctxt hs_kind--- See  Note [Recipe for checking a signature] in TcHsType--- Result is zonked-  = do { kind <- solveLocalEqualities "tcLHsKindSig" $-                 tc_lhs_kind kindLevelMode hs_kind-       ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind)-       -- No generalization, so we must promote-       ; kind <- zonkPromoteType kind-         -- This zonk is very important in the case of higher rank kinds-         -- E.g. Trac #13879    f :: forall (p :: forall z (y::z). <blah>).-         --                          <more blah>-         --      When instantiating p's kind at occurrences of p in <more blah>-         --      it's crucial that the kind we instantiate is fully zonked,-         --      else we may fail to substitute properly--       ; checkValidType ctxt kind-       ; traceTc "tcLHsKindSig2" (ppr kind)-       ; return kind }--tc_lhs_kind :: TcTyMode -> LHsKind GhcRn -> TcM Kind-tc_lhs_kind mode k-  = addErrCtxt (text "In the kind" <+> quotes (ppr k)) $-    tc_lhs_type (kindLevel mode) k liftedTypeKind--promotionErr :: Name -> PromotionErr -> TcM a-promotionErr name err-  = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here")-                   2 (parens reason))-  where-    reason = case err of-               ConstrainedDataConPE pred-                              -> text "it has an unpromotable context"-                                 <+> quotes (ppr pred)-               FamDataConPE   -> text "it comes from a data family instance"-               NoDataKindsTC  -> text "perhaps you intended to use DataKinds"-               NoDataKindsDC  -> text "perhaps you intended to use DataKinds"-               PatSynPE       -> text "pattern synonyms cannot be promoted"-               PatSynExPE     -> sep [ text "the existential variables of a pattern synonym"-                                     , text "signature do not scope over the pattern" ]-               _ -> text "it is defined and used in the same recursive group"--{--************************************************************************-*                                                                      *-                Scoped type variables-*                                                                      *-************************************************************************--}--badPatTyVarTvs :: TcType -> [TyVar] -> SDoc-badPatTyVarTvs sig_ty bad_tvs-  = vcat [ fsep [text "The type variable" <> plural bad_tvs,-                 quotes (pprWithCommas ppr bad_tvs),-                 text "should be bound by the pattern signature" <+> quotes (ppr sig_ty),-                 text "but are actually discarded by a type synonym" ]-         , text "To fix this, expand the type synonym"-         , text "[Note: I hope to lift this restriction in due course]" ]--{--************************************************************************-*                                                                      *-          Error messages and such-*                                                                      *-************************************************************************--}---{- Note [Free-floating kind vars]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider--  data S a = MkS (Proxy (a :: k))--According to the rules around implicitly-bound kind variables,-that k scopes over the whole declaration. The renamer grabs-it and adds it to the hsq_implicits field of the HsQTyVars of the-tycon.  So we get-   S :: forall {k}. k -> Type--That's fine.  But consider this variant:-  data T = MkT (forall (a :: k). Proxy a)-  -- from test ghci/scripts/T7873--This is not an existential datatype, but a higher-rank one (the forall-to the right of MkT). Again, 'k' scopes over the whole declaration,-but we do not want to get-   T :: forall {k}. Type-Why not? Because the kind variable isn't fixed by anything. For-a variable like k to be implicit, it needs to be mentioned in the kind-of a tycon tyvar. But it isn't.--Rejecting T depends on whether or not the datatype has a CUSK.--Non-CUSK (handled in TcTyClsDecls.kcTyClGroup (generalise)):-   When generalising the TyCon we check that every Specified 'k'-   appears free in the kind of the TyCon; that is, in the kind of-   one of its Required arguments, or the result kind.--CUSK (handled in TcHsType.kcLHsQTyVars, the CUSK case):-   When we determine the tycon's final, never-to-be-changed kind-   in kcLHsQTyVars, we check to make sure all implicitly-bound kind-   vars are indeed mentioned in a kind somewhere. If not, error.--We also perform free-floating kind var analysis for type family instances-(see #13985). Here is an interesting example:--    type family   T :: k-    type instance T = (Nothing :: Maybe a)--Upon a cursory glance, it may appear that the kind variable `a` is-free-floating above, since there are no (visible) LHS patterns in `T`. However,-there is an *invisible* pattern due to the return kind, so inside of GHC, the-instance looks closer to this:--    type family T @k :: k-    type instance T @(Maybe a) = (Nothing :: Maybe a)--Here, we can see that `a` really is bound by a LHS type pattern, so `a` is in-fact not free-floating. Contrast that with this example:--    type instance T = Proxy (Nothing :: Maybe a)--This would looks like this inside of GHC:--    type instance T @(*) = Proxy (Nothing :: Maybe a)--So this time, `a` is neither bound by a visible nor invisible type pattern on-the LHS, so it would be reported as free-floating.--Finally, here's one more brain-teaser (from #9574). In the example below:--    class Funct f where-      type Codomain f :: *-    instance Funct ('KProxy :: KProxy o) where-      type Codomain 'KProxy = NatTr (Proxy :: o -> *)--As it turns out, `o` is not free-floating in this example. That is because `o`-bound by the kind signature of the LHS type pattern 'KProxy. To make this more-obvious, one can also write the instance like so:--    instance Funct ('KProxy :: KProxy o) where-      type Codomain ('KProxy :: KProxy o) = NatTr (Proxy :: o -> *)--}---- See Note [Free-floating kind vars]-reportFloatingKvs :: Name         -- of the tycon-                  -> TyConFlavour -- What sort of TyCon it is-                  -> [TcTyVar]    -- all tyvars, not necessarily zonked-                  -> [TcTyVar]    -- floating tyvars-                  -> TcM ()-reportFloatingKvs tycon_name flav all_tvs bad_tvs-  = unless (null bad_tvs) $  -- don't bother zonking if there's no error-    do { all_tvs <- mapM zonkTcTyVarToTyVar all_tvs-       ; bad_tvs <- mapM zonkTcTyVarToTyVar bad_tvs-       ; let (tidy_env, tidy_all_tvs) = tidyOpenTyCoVars emptyTidyEnv all_tvs-             tidy_bad_tvs             = map (tidyTyCoVarOcc tidy_env) bad_tvs-       ; mapM_ (report tidy_all_tvs) tidy_bad_tvs }-  where-    report tidy_all_tvs tidy_bad_tv-      = addErr $-        vcat [ text "Kind variable" <+> quotes (ppr tidy_bad_tv) <+>-               text "is implicitly bound in" <+> ppr flav-             , quotes (ppr tycon_name) <> comma <+>-               text "but does not appear as the kind of any"-             , text "of its type variables. Perhaps you meant"-             , text "to bind it explicitly somewhere?"-             , ppWhen (not (null tidy_all_tvs)) $-                 hang (text "Type variables with inferred kinds:")-                 2 (ppr_tv_bndrs tidy_all_tvs) ]--    ppr_tv_bndrs tvs = sep (map pp_tv tvs)-    pp_tv tv         = parens (ppr tv <+> dcolon <+> ppr (tyVarKind tv))+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module TcHsType (+        -- Type signatures+        kcClassSigType, tcClassSigType,+        tcHsSigType, tcHsSigWcType,+        tcHsPartialSigType,+        tcStandaloneKindSig,+        funsSigCtxt, addSigCtxt, pprSigCtxt,++        tcHsClsInstType,+        tcHsDeriv, tcDerivStrategy,+        tcHsTypeApp,+        UserTypeCtxt(..),+        bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol,+            bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol,+        bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol,+            bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol,+        ContextKind(..),++                -- Type checking type and class decls+        kcLookupTcTyCon, bindTyClTyVars,+        etaExpandAlgTyCon, tcbVisibilities,++          -- tyvars+        zonkAndScopedSort,++        -- Kind-checking types+        -- No kind generalisation, no checkValidType+        InitialKindStrategy(..),+        SAKS_or_CUSK(..),+        kcDeclHeader,+        tcNamedWildCardBinders,+        tcHsLiftedType,   tcHsOpenType,+        tcHsLiftedTypeNC, tcHsOpenTypeNC,+        tcLHsType, tcLHsTypeUnsaturated, tcCheckLHsType,+        tcHsMbContext, tcHsContext, tcLHsPredType, tcInferApps,+        failIfEmitsConstraints,+        solveEqualities, -- useful re-export++        typeLevelMode, kindLevelMode,++        kindGeneralizeAll, kindGeneralizeSome, kindGeneralizeNone,+        checkExpectedKind_pp,++        -- Sort-checking kinds+        tcLHsKindSig, checkDataKindSig, DataSort(..),+        checkClassKindSig,++        -- Pattern type signatures+        tcHsPatSigType, tcPatSig,++        -- Error messages+        funAppCtxt, addTyConFlavCtxt+   ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Hs+import TcRnMonad+import TcOrigin+import Predicate+import Constraint+import TcEvidence+import TcEnv+import TcMType+import TcValidity+import TcUnify+import TcIface+import TcSimplify+import TcHsSyn+import TyCoRep+import TyCoPpr+import TcErrors ( reportAllUnsolved )+import TcType+import Inst   ( tcInstInvisibleTyBinders, tcInstInvisibleTyBinder )+import Type+import TysPrim+import RdrName( lookupLocalRdrOcc )+import Var+import VarSet+import TyCon+import ConLike+import DataCon+import Class+import Name+-- import NameSet+import VarEnv+import TysWiredIn+import BasicTypes+import SrcLoc+import Constants ( mAX_CTUPLE_SIZE )+import ErrUtils( MsgDoc )+import Unique+import UniqSet+import Util+import UniqSupply+import Outputable+import FastString+import PrelNames hiding ( wildCardName )+import DynFlags+import qualified GHC.LanguageExtensions as LangExt++import Maybes+import Data.List ( find )+import Control.Monad++{-+        ----------------------------+                General notes+        ----------------------------++Unlike with expressions, type-checking types both does some checking and+desugars at the same time. This is necessary because we often want to perform+equality checks on the types right away, and it would be incredibly painful+to do this on un-desugared types. Luckily, desugared types are close enough+to HsTypes to make the error messages sane.++During type-checking, we perform as little validity checking as possible.+Generally, after type-checking, you will want to do validity checking, say+with TcValidity.checkValidType.++Validity checking+~~~~~~~~~~~~~~~~~+Some of the validity check could in principle be done by the kind checker,+but not all:++- During desugaring, we normalise by expanding type synonyms.  Only+  after this step can we check things like type-synonym saturation+  e.g.  type T k = k Int+        type S a = a+  Then (T S) is ok, because T is saturated; (T S) expands to (S Int);+  and then S is saturated.  This is a GHC extension.++- Similarly, also a GHC extension, we look through synonyms before complaining+  about the form of a class or instance declaration++- Ambiguity checks involve functional dependencies++Also, in a mutually recursive group of types, we can't look at the TyCon until we've+finished building the loop.  So to keep things simple, we postpone most validity+checking until step (3).++%************************************************************************+%*                                                                      *+              Check types AND do validity checking+*                                                                      *+************************************************************************+-}++funsSigCtxt :: [Located Name] -> UserTypeCtxt+-- Returns FunSigCtxt, with no redundant-context-reporting,+-- form a list of located names+funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False+funsSigCtxt []              = panic "funSigCtxt"++addSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> TcM a -> TcM a+addSigCtxt ctxt hs_ty thing_inside+  = setSrcSpan (getLoc hs_ty) $+    addErrCtxt (pprSigCtxt ctxt hs_ty) $+    thing_inside++pprSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> SDoc+-- (pprSigCtxt ctxt <extra> <type>)+-- prints    In the type signature for 'f':+--              f :: <type>+-- The <extra> is either empty or "the ambiguity check for"+pprSigCtxt ctxt hs_ty+  | Just n <- isSigMaybe ctxt+  = hang (text "In the type signature:")+       2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty)++  | otherwise+  = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon)+       2 (ppr hs_ty)++tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type+-- This one is used when we have a LHsSigWcType, but in+-- a place where wildcards aren't allowed. The renamer has+-- already checked this, so we can simply ignore it.+tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty)++kcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM ()+kcClassSigType skol_info names sig_ty+  = discardResult $+    tcClassSigType skol_info names sig_ty+  -- tcClassSigType does a fair amount of extra work that we don't need,+  -- such as ordering quantified variables. But we absolutely do need+  -- to push the level when checking method types and solve local equalities,+  -- and so it seems easier just to call tcClassSigType than selectively+  -- extract the lines of code from tc_hs_sig_type that we really need.+  -- If we don't push the level, we get #16517, where GHC accepts+  --   class C a where+  --     meth :: forall k. Proxy (a :: k) -> ()+  -- Note that k is local to meth -- this is hogwash.++tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type+-- Does not do validity checking+tcClassSigType skol_info names sig_ty+  = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $+    snd <$> tc_hs_sig_type skol_info sig_ty (TheKind liftedTypeKind)+       -- Do not zonk-to-Type, nor perform a validity check+       -- We are in a knot with the class and associated types+       -- Zonking and validity checking is done by tcClassDecl+       -- No need to fail here if the type has an error:+       --   If we're in the kind-checking phase, the solveEqualities+       --     in kcTyClGroup catches the error+       --   If we're in the type-checking phase, the solveEqualities+       --     in tcClassDecl1 gets it+       -- Failing fast here degrades the error message in, e.g., tcfail135:+       --   class Foo f where+       --     baa :: f a -> f+       -- If we fail fast, we're told that f has kind `k1` when we wanted `*`.+       -- It should be that f has kind `k2 -> *`, but we never get a chance+       -- to run the solver where the kind of f is touchable. This is+       -- painfully delicate.++tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type+-- Does validity checking+-- See Note [Recipe for checking a signature]+tcHsSigType ctxt sig_ty+  = addSigCtxt ctxt (hsSigType sig_ty) $+    do { traceTc "tcHsSigType {" (ppr sig_ty)++          -- Generalise here: see Note [Kind generalisation]+       ; (insol, ty) <- tc_hs_sig_type skol_info sig_ty+                                       (expectedKindInCtxt ctxt)+       ; ty <- zonkTcType ty++       ; when insol failM+       -- See Note [Fail fast if there are insoluble kind equalities] in TcSimplify++       ; checkValidType ctxt ty+       ; traceTc "end tcHsSigType }" (ppr ty)+       ; return ty }+  where+    skol_info = SigTypeSkol ctxt++-- Does validity checking and zonking.+tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind)+tcStandaloneKindSig (L _ kisig) = case kisig of+  StandaloneKindSig _ (L _ name) ksig ->+    let ctxt = StandaloneKindSigCtxt name in+    addSigCtxt ctxt (hsSigType ksig) $+    do { kind <- tcTopLHsType kindLevelMode ksig (expectedKindInCtxt ctxt)+       ; checkValidType ctxt kind+       ; return (name, kind) }+  XStandaloneKindSig nec -> noExtCon nec++tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn+               -> ContextKind -> TcM (Bool, TcType)+-- Kind-checks/desugars an 'LHsSigType',+--   solve equalities,+--   and then kind-generalizes.+-- This will never emit constraints, as it uses solveEqualities interally.+-- No validity checking or zonking+-- Returns also a Bool indicating whether the type induced an insoluble constraint;+-- True <=> constraint is insoluble+tc_hs_sig_type skol_info hs_sig_type ctxt_kind+  | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type+  = do { (tc_lvl, (wanted, (spec_tkvs, ty)))+              <- pushTcLevelM                           $+                 solveLocalEqualitiesX "tc_hs_sig_type" $+                 bindImplicitTKBndrs_Skol sig_vars      $+                 do { kind <- newExpectedKind ctxt_kind+                    ; tc_lhs_type typeLevelMode hs_ty kind }+       -- Any remaining variables (unsolved in the solveLocalEqualities)+       -- should be in the global tyvars, and therefore won't be quantified++       ; spec_tkvs <- zonkAndScopedSort spec_tkvs+       ; let ty1 = mkSpecForAllTys spec_tkvs ty++       -- This bit is very much like decideMonoTyVars in TcSimplify,+       -- but constraints are so much simpler in kinds, it is much+       -- easier here. (In particular, we never quantify over a+       -- constraint in a type.)+       ; constrained <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted)+       ; let should_gen = not . (`elemVarSet` constrained)++       ; kvs <- kindGeneralizeSome should_gen ty1+       ; emitResidualTvConstraint skol_info Nothing (kvs ++ spec_tkvs)+                                  tc_lvl wanted++       ; return (insolubleWC wanted, mkInvForAllTys kvs ty1) }++tc_hs_sig_type _ (XHsImplicitBndrs nec) _ = noExtCon nec++tcTopLHsType :: TcTyMode -> LHsSigType GhcRn -> ContextKind -> TcM Type+-- tcTopLHsType is used for kind-checking top-level HsType where+--   we want to fully solve /all/ equalities, and report errors+-- Does zonking, but not validity checking because it's used+--   for things (like deriving and instances) that aren't+--   ordinary types+tcTopLHsType mode hs_sig_type ctxt_kind+  | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type+  = do { traceTc "tcTopLHsType {" (ppr hs_ty)+       ; (spec_tkvs, ty)+              <- pushTcLevelM_                     $+                 solveEqualities                   $+                 bindImplicitTKBndrs_Skol sig_vars $+                 do { kind <- newExpectedKind ctxt_kind+                    ; tc_lhs_type mode hs_ty kind }++       ; spec_tkvs <- zonkAndScopedSort spec_tkvs+       ; let ty1 = mkSpecForAllTys spec_tkvs ty+       ; kvs <- kindGeneralizeAll ty1  -- "All" because it's a top-level type+       ; final_ty <- zonkTcTypeToType (mkInvForAllTys kvs ty1)+       ; traceTc "End tcTopLHsType }" (vcat [ppr hs_ty, ppr final_ty])+       ; return final_ty}++tcTopLHsType _ (XHsImplicitBndrs nec) _ = noExtCon nec++-----------------+tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind])+-- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause+-- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments+-- E.g.    class C (a::*) (b::k->k)+--         data T a b = ... deriving( C Int )+--    returns ([k], C, [k, Int], [k->k])+-- Return values are fully zonked+tcHsDeriv hs_ty+  = do { ty <- checkNoErrs $  -- Avoid redundant error report+                              -- with "illegal deriving", below+               tcTopLHsType typeLevelMode hs_ty AnyKind+       ; let (tvs, pred)    = splitForAllTys ty+             (kind_args, _) = splitFunTys (tcTypeKind pred)+       ; case getClassPredTys_maybe pred of+           Just (cls, tys) -> return (tvs, cls, tys, kind_args)+           Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) }++-- | Typecheck a deriving strategy. For most deriving strategies, this is a+-- no-op, but for the @via@ strategy, this requires typechecking the @via@ type.+tcDerivStrategy ::+     Maybe (LDerivStrategy GhcRn)+     -- ^ The deriving strategy+  -> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])+     -- ^ The typechecked deriving strategy and the tyvars that it binds+     -- (if using 'ViaStrategy').+tcDerivStrategy mb_lds+  = case mb_lds of+      Nothing -> boring_case Nothing+      Just (dL->L loc ds) ->+        setSrcSpan loc $ do+          (ds', tvs) <- tc_deriv_strategy ds+          pure (Just (cL loc ds'), tvs)+  where+    tc_deriv_strategy :: DerivStrategy GhcRn+                      -> TcM (DerivStrategy GhcTc, [TyVar])+    tc_deriv_strategy StockStrategy    = boring_case StockStrategy+    tc_deriv_strategy AnyclassStrategy = boring_case AnyclassStrategy+    tc_deriv_strategy NewtypeStrategy  = boring_case NewtypeStrategy+    tc_deriv_strategy (ViaStrategy ty) = do+      ty' <- checkNoErrs $ tcTopLHsType typeLevelMode ty AnyKind+      let (via_tvs, via_pred) = splitForAllTys ty'+      pure (ViaStrategy via_pred, via_tvs)++    boring_case :: ds -> TcM (ds, [TyVar])+    boring_case ds = pure (ds, [])++tcHsClsInstType :: UserTypeCtxt    -- InstDeclCtxt or SpecInstCtxt+                -> LHsSigType GhcRn+                -> TcM Type+-- Like tcHsSigType, but for a class instance declaration+tcHsClsInstType user_ctxt hs_inst_ty+  = setSrcSpan (getLoc (hsSigType hs_inst_ty)) $+    do { -- Fail eagerly if tcTopLHsType fails.  We are at top level so+         -- these constraints will never be solved later. And failing+         -- eagerly avoids follow-on errors when checkValidInstance+         -- sees an unsolved coercion hole+         inst_ty <- checkNoErrs $+                    tcTopLHsType typeLevelMode hs_inst_ty (TheKind constraintKind)+       ; checkValidInstance user_ctxt hs_inst_ty inst_ty+       ; return inst_ty }++----------------------------------------------+-- | Type-check a visible type application+tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type+-- See Note [Recipe for checking a signature] in TcHsType+tcHsTypeApp wc_ty kind+  | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty+  = do { ty <- solveLocalEqualities "tcHsTypeApp" $+               -- We are looking at a user-written type, very like a+               -- signature so we want to solve its equalities right now+               unsetWOptM Opt_WarnPartialTypeSignatures $+               setXOptM LangExt.PartialTypeSignatures $+               -- See Note [Wildcards in visible type application]+               tcNamedWildCardBinders sig_wcs $ \ _ ->+               tcCheckLHsType hs_ty kind+       -- We do not kind-generalize type applications: we just+       -- instantiate with exactly what the user says.+       -- See Note [No generalization in type application]+       -- We still must call kindGeneralizeNone, though, according+       -- to Note [Recipe for checking a signature]+       ; kindGeneralizeNone ty+       ; ty <- zonkTcType ty+       ; checkValidType TypeAppCtxt ty+       ; return ty }+tcHsTypeApp (XHsWildCardBndrs nec) _ = noExtCon nec++{- Note [Wildcards in visible type application]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A HsWildCardBndrs's hswc_ext now only includes /named/ wildcards, so+any unnamed wildcards stay unchanged in hswc_body.  When called in+tcHsTypeApp, tcCheckLHsType will call emitAnonWildCardHoleConstraint+on these anonymous wildcards. However, this would trigger+error/warning when an anonymous wildcard is passed in as a visible type+argument, which we do not want because users should be able to write+@_ to skip a instantiating a type variable variable without fuss. The+solution is to switch the PartialTypeSignatures flags here to let the+typechecker know that it's checking a '@_' and do not emit hole+constraints on it.  See related Note [Wildcards in visible kind+application] and Note [The wildcard story for types] in GHC.Hs.Types++Ugh!++Note [No generalization in type application]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not kind-generalize type applications. Imagine++  id @(Proxy Nothing)++If we kind-generalized, we would get++  id @(forall {k}. Proxy @(Maybe k) (Nothing @k))++which is very sneakily impredicative instantiation.++There is also the possibility of mentioning a wildcard+(`id @(Proxy _)`), which definitely should not be kind-generalized.++-}++{-+************************************************************************+*                                                                      *+            The main kind checker: no validity checks here+*                                                                      *+************************************************************************+-}++---------------------------+tcHsOpenType, tcHsLiftedType,+  tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType+-- Used for type signatures+-- Do not do validity checking+tcHsOpenType ty   = addTypeCtxt ty $ tcHsOpenTypeNC ty+tcHsLiftedType ty = addTypeCtxt ty $ tcHsLiftedTypeNC ty++tcHsOpenTypeNC   ty = do { ek <- newOpenTypeKind+                         ; tc_lhs_type typeLevelMode ty ek }+tcHsLiftedTypeNC ty = tc_lhs_type typeLevelMode ty liftedTypeKind++-- Like tcHsType, but takes an expected kind+tcCheckLHsType :: LHsType GhcRn -> Kind -> TcM TcType+tcCheckLHsType hs_ty exp_kind+  = addTypeCtxt hs_ty $+    tc_lhs_type typeLevelMode hs_ty exp_kind++tcLHsType :: LHsType GhcRn -> TcM (TcType, TcKind)+-- Called from outside: set the context+tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type typeLevelMode ty)++-- Like tcLHsType, but use it in a context where type synonyms and type families+-- do not need to be saturated, like in a GHCi :kind call+tcLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind)+tcLHsTypeUnsaturated hs_ty+  | Just (hs_fun_ty, hs_args) <- splitHsAppTys (unLoc hs_ty)+  = addTypeCtxt hs_ty $+    do { (fun_ty, _ki) <- tcInferAppHead mode hs_fun_ty+       ; tcInferApps_nosat mode hs_fun_ty fun_ty hs_args }+         -- Notice the 'nosat'; do not instantiate trailing+         -- invisible arguments of a type family.+         -- See Note [Dealing with :kind]++  | otherwise+  = addTypeCtxt hs_ty $+    tc_infer_lhs_type mode hs_ty++  where+    mode = typeLevelMode++{- Note [Dealing with :kind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this GHCi command+  ghci> type family F :: Either j k+  ghci> :kind F+  F :: forall {j,k}. Either j k++We will only get the 'forall' if we /refrain/ from saturating those+invisible binders. But generally we /do/ saturate those invisible+binders (see tcInferApps), and we want to do so for nested application+even in GHCi.  Consider for example (#16287)+  ghci> type family F :: k+  ghci> data T :: (forall k. k) -> Type+  ghci> :kind T F+We want to reject this. It's just at the very top level that we want+to switch off saturation.++So tcLHsTypeUnsaturated does a little special case for top level+applications.  Actually the common case is a bare variable, as above.+++************************************************************************+*                                                                      *+      Type-checking modes+*                                                                      *+************************************************************************++The kind-checker is parameterised by a TcTyMode, which contains some+information about where we're checking a type.++The renamer issues errors about what it can. All errors issued here must+concern things that the renamer can't handle.++-}++-- | Info about the context in which we're checking a type. Currently,+-- differentiates only between types and kinds, but this will likely+-- grow, at least to include the distinction between patterns and+-- not-patterns.+--+-- To find out where the mode is used, search for 'mode_level'+data TcTyMode = TcTyMode { mode_level :: TypeOrKind }++typeLevelMode :: TcTyMode+typeLevelMode = TcTyMode { mode_level = TypeLevel }++kindLevelMode :: TcTyMode+kindLevelMode = TcTyMode { mode_level = KindLevel }++-- switch to kind level+kindLevel :: TcTyMode -> TcTyMode+kindLevel mode = mode { mode_level = KindLevel }++instance Outputable TcTyMode where+  ppr = ppr . mode_level++{-+Note [Bidirectional type checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In expressions, whenever we see a polymorphic identifier, say `id`, we are+free to instantiate it with metavariables, knowing that we can always+re-generalize with type-lambdas when necessary. For example:++  rank2 :: (forall a. a -> a) -> ()+  x = rank2 id++When checking the body of `x`, we can instantiate `id` with a metavariable.+Then, when we're checking the application of `rank2`, we notice that we really+need a polymorphic `id`, and then re-generalize over the unconstrained+metavariable.++In types, however, we're not so lucky, because *we cannot re-generalize*!+There is no lambda. So, we must be careful only to instantiate at the last+possible moment, when we're sure we're never going to want the lost polymorphism+again. This is done in calls to tcInstInvisibleTyBinders.++To implement this behavior, we use bidirectional type checking, where we+explicitly think about whether we know the kind of the type we're checking+or not. Note that there is a difference between not knowing a kind and+knowing a metavariable kind: the metavariables are TauTvs, and cannot become+forall-quantified kinds. Previously (before dependent types), there were+no higher-rank kinds, and so we could instantiate early and be sure that+no types would have polymorphic kinds, and so we could always assume that+the kind of a type was a fresh metavariable. Not so anymore, thus the+need for two algorithms.++For HsType forms that can never be kind-polymorphic, we implement only the+"down" direction, where we safely assume a metavariable kind. For HsType forms+that *can* be kind-polymorphic, we implement just the "up" (functions with+"infer" in their name) version, as we gain nothing by also implementing the+"down" version.++Note [Future-proofing the type checker]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As discussed in Note [Bidirectional type checking], each HsType form is+handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions+are mutually recursive, so that either one can work for any type former.+But, we want to make sure that our pattern-matches are complete. So,+we have a bunch of repetitive code just so that we get warnings if we're+missing any patterns.++-}++------------------------------------------+-- | Check and desugar a type, returning the core type and its+-- possibly-polymorphic kind. Much like 'tcInferRho' at the expression+-- level.+tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)+tc_infer_lhs_type mode (L span ty)+  = setSrcSpan span $+    tc_infer_hs_type mode ty++---------------------------+-- | Call 'tc_infer_hs_type' and check its result against an expected kind.+tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType+tc_infer_hs_type_ek mode hs_ty ek+  = do { (ty, k) <- tc_infer_hs_type mode hs_ty+       ; checkExpectedKind hs_ty ty k ek }++---------------------------+-- | Infer the kind of a type and desugar. This is the "up" type-checker,+-- as described in Note [Bidirectional type checking]+tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind)++tc_infer_hs_type mode (HsParTy _ t)+  = tc_infer_lhs_type mode t++tc_infer_hs_type mode ty+  | Just (hs_fun_ty, hs_args) <- splitHsAppTys ty+  = do { (fun_ty, _ki) <- tcInferAppHead mode hs_fun_ty+       ; tcInferApps mode hs_fun_ty fun_ty hs_args }++tc_infer_hs_type mode (HsKindSig _ ty sig)+  = do { sig' <- tcLHsKindSig KindSigCtxt sig+                 -- We must typecheck the kind signature, and solve all+                 -- its equalities etc; from this point on we may do+                 -- things like instantiate its foralls, so it needs+                 -- to be fully determined (#14904)+       ; traceTc "tc_infer_hs_type:sig" (ppr ty $$ ppr sig')+       ; ty' <- tc_lhs_type mode ty sig'+       ; return (ty', sig') }++-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType' to communicate+-- the splice location to the typechecker. Here we skip over it in order to have+-- the same kind inferred for a given expression whether it was produced from+-- splices or not.+--+-- See Note [Delaying modFinalizers in untyped splices].+tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)))+  = tc_infer_hs_type mode ty++tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty+tc_infer_hs_type _    (XHsType (NHsCoreTy ty))+  = return (ty, tcTypeKind ty)++tc_infer_hs_type _ (HsExplicitListTy _ _ tys)+  | null tys  -- this is so that we can use visible kind application with '[]+              -- e.g ... '[] @Bool+  = return (mkTyConTy promotedNilDataCon,+            mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy)++tc_infer_hs_type mode other_ty+  = do { kv <- newMetaKindVar+       ; ty' <- tc_hs_type mode other_ty kv+       ; return (ty', kv) }++------------------------------------------+tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType+tc_lhs_type mode (L span ty) exp_kind+  = setSrcSpan span $+    tc_hs_type mode ty exp_kind++tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType+-- See Note [Bidirectional type checking]++tc_hs_type mode (HsParTy _ ty)   exp_kind = tc_lhs_type mode ty exp_kind+tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind+tc_hs_type _ ty@(HsBangTy _ bang _) _+    -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),+    -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of+    -- bangs are invalid, so fail. (#7210, #14761)+    = do { let bangError err = failWith $+                 text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$+                 text err <+> text "annotation cannot appear nested inside a type"+         ; case bang of+             HsSrcBang _ SrcUnpack _           -> bangError "UNPACK"+             HsSrcBang _ SrcNoUnpack _         -> bangError "NOUNPACK"+             HsSrcBang _ NoSrcUnpack SrcLazy   -> bangError "laziness"+             HsSrcBang _ _ _                   -> bangError "strictness" }+tc_hs_type _ ty@(HsRecTy {})      _+      -- Record types (which only show up temporarily in constructor+      -- signatures) should have been removed by now+    = failWithTc (text "Record syntax is illegal here:" <+> ppr ty)++-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType'.+-- Here we get rid of it and add the finalizers to the global environment+-- while capturing the local environment.+--+-- See Note [Delaying modFinalizers in untyped splices].+tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty)))+           exp_kind+  = do addModFinalizersWithLclEnv mod_finalizers+       tc_hs_type mode ty exp_kind++-- This should never happen; type splices are expanded by the renamer+tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind+  = failWithTc (text "Unexpected type splice:" <+> ppr ty)++---------- Functions and applications+tc_hs_type mode (HsFunTy _ ty1 ty2) exp_kind+  = tc_fun_type mode ty1 ty2 exp_kind++tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind+  | op `hasKey` funTyConKey+  = tc_fun_type mode ty1 ty2 exp_kind++--------- Foralls+tc_hs_type mode forall@(HsForAllTy { hst_fvf = fvf, hst_bndrs = hs_tvs+                                   , hst_body = ty }) exp_kind+  = do { (tclvl, wanted, (tvs', ty'))+            <- pushLevelAndCaptureConstraints $+               bindExplicitTKBndrs_Skol hs_tvs $+               tc_lhs_type mode ty exp_kind+    -- Do not kind-generalise here!  See Note [Kind generalisation]+    -- Why exp_kind?  See Note [Body kind of HsForAllTy]+       ; let argf        = case fvf of+                             ForallVis   -> Required+                             ForallInvis -> Specified+             bndrs       = mkTyVarBinders argf tvs'+             skol_info   = ForAllSkol (ppr forall)+             m_telescope = Just (sep (map ppr hs_tvs))++       ; emitResidualTvConstraint skol_info m_telescope tvs' tclvl wanted++       ; return (mkForAllTys bndrs ty') }++tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind+  | null (unLoc ctxt)+  = tc_lhs_type mode rn_ty exp_kind++  -- See Note [Body kind of a HsQualTy]+  | tcIsConstraintKind exp_kind+  = do { ctxt' <- tc_hs_context mode ctxt+       ; ty'   <- tc_lhs_type mode rn_ty constraintKind+       ; return (mkPhiTy ctxt' ty') }++  | otherwise+  = do { ctxt' <- tc_hs_context mode ctxt++       ; ek <- newOpenTypeKind  -- The body kind (result of the function) can+                                -- be TYPE r, for any r, hence newOpenTypeKind+       ; ty' <- tc_lhs_type mode rn_ty ek+       ; checkExpectedKind (unLoc rn_ty) (mkPhiTy ctxt' ty')+                           liftedTypeKind exp_kind }++--------- Lists, arrays, and tuples+tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind+  = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind+       ; checkWiredInTyCon listTyCon+       ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind }++-- See Note [Distinguishing tuple kinds] in GHC.Hs.Types+-- See Note [Inferring tuple kinds]+tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind+     -- (NB: not zonking before looking at exp_k, to avoid left-right bias)+  | Just tup_sort <- tupKindSort_maybe exp_kind+  = traceTc "tc_hs_type tuple" (ppr hs_tys) >>+    tc_tuple rn_ty mode tup_sort hs_tys exp_kind+  | otherwise+  = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys)+       ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys+       ; kinds <- mapM zonkTcType kinds+           -- Infer each arg type separately, because errors can be+           -- confusing if we give them a shared kind.  Eg #7410+           -- (Either Int, Int), we do not want to get an error saying+           -- "the second argument of a tuple should have kind *->*"++       ; let (arg_kind, tup_sort)+               = case [ (k,s) | k <- kinds+                              , Just s <- [tupKindSort_maybe k] ] of+                    ((k,s) : _) -> (k,s)+                    [] -> (liftedTypeKind, BoxedTuple)+         -- In the [] case, it's not clear what the kind is, so guess *++       ; tys' <- sequence [ setSrcSpan loc $+                            checkExpectedKind hs_ty ty kind arg_kind+                          | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ]++       ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind }+++tc_hs_type mode rn_ty@(HsTupleTy _ hs_tup_sort tys) exp_kind+  = tc_tuple rn_ty mode tup_sort tys exp_kind+  where+    tup_sort = case hs_tup_sort of  -- Fourth case dealt with above+                  HsUnboxedTuple    -> UnboxedTuple+                  HsBoxedTuple      -> BoxedTuple+                  HsConstraintTuple -> ConstraintTuple+                  _                 -> panic "tc_hs_type HsTupleTy"++tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind+  = do { let arity = length hs_tys+       ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys+       ; tau_tys   <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds+       ; let arg_reps = map kindRep arg_kinds+             arg_tys  = arg_reps ++ tau_tys+             sum_ty   = mkTyConApp (sumTyCon arity) arg_tys+             sum_kind = unboxedSumKind arg_reps+       ; checkExpectedKind rn_ty sum_ty sum_kind exp_kind+       }++--------- Promoted lists and tuples+tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind+  = do { tks <- mapM (tc_infer_lhs_type mode) tys+       ; (taus', kind) <- unifyKinds tys tks+       ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus')+       ; checkExpectedKind rn_ty ty (mkListTy kind) exp_kind }+  where+    mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b]+    mk_nil  k     = mkTyConApp (promoteDataCon nilDataCon) [k]++tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind+  -- using newMetaKindVar means that we force instantiations of any polykinded+  -- types. At first, I just used tc_infer_lhs_type, but that led to #11255.+  = do { ks   <- replicateM arity newMetaKindVar+       ; taus <- zipWithM (tc_lhs_type mode) tys ks+       ; let kind_con   = tupleTyCon           Boxed arity+             ty_con     = promotedTupleDataCon Boxed arity+             tup_k      = mkTyConApp kind_con ks+       ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind }+  where+    arity = length tys++--------- Constraint types+tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind+  = do { MASSERT( isTypeLevel (mode_level mode) )+       ; ty' <- tc_lhs_type mode ty liftedTypeKind+       ; let n' = mkStrLitTy $ hsIPNameFS n+       ; ipClass <- tcLookupClass ipClassName+       ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty'])+                           constraintKind exp_kind }++tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind+  -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to+  -- handle it in 'coreView' and 'tcView'.+  = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind++--------- Literals+tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind+  = do { checkWiredInTyCon typeNatKindCon+       ; checkExpectedKind rn_ty (mkNumLitTy n) typeNatKind exp_kind }++tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind+  = do { checkWiredInTyCon typeSymbolKindCon+       ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind }++--------- Potentially kind-polymorphic types: call the "up" checker+-- See Note [Future-proofing the type checker]+tc_hs_type mode ty@(HsTyVar {})            ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsAppTy {})            ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsAppKindTy{})         ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsOpTy {})             ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsKindSig {})          ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(XHsType (NHsCoreTy{})) ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type _    wc@(HsWildCardTy _)        ek = tcAnonWildCardOcc wc ek++------------------------------------------+tc_fun_type :: TcTyMode -> LHsType GhcRn -> LHsType GhcRn -> TcKind+            -> TcM TcType+tc_fun_type mode ty1 ty2 exp_kind = case mode_level mode of+  TypeLevel ->+    do { arg_k <- newOpenTypeKind+       ; res_k <- newOpenTypeKind+       ; ty1' <- tc_lhs_type mode ty1 arg_k+       ; ty2' <- tc_lhs_type mode ty2 res_k+       ; checkExpectedKind (HsFunTy noExtField ty1 ty2) (mkVisFunTy ty1' ty2')+                           liftedTypeKind exp_kind }+  KindLevel ->  -- no representation polymorphism in kinds. yet.+    do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind+       ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind+       ; checkExpectedKind (HsFunTy noExtField ty1 ty2) (mkVisFunTy ty1' ty2')+                           liftedTypeKind exp_kind }++---------------------------+tcAnonWildCardOcc :: HsType GhcRn -> Kind -> TcM TcType+tcAnonWildCardOcc wc exp_kind+  = do { wc_tv <- newWildTyVar  -- The wildcard's kind will be an un-filled-in meta tyvar++       ; part_tysig <- xoptM LangExt.PartialTypeSignatures+       ; warning <- woptM Opt_WarnPartialTypeSignatures++       ; unless (part_tysig && not warning) $+         emitAnonWildCardHoleConstraint wc_tv+         -- Why the 'unless' guard?+         -- See Note [Wildcards in visible kind application]++       ; checkExpectedKind wc (mkTyVarTy wc_tv)+                           (tyVarKind wc_tv) exp_kind }++{- Note [Wildcards in visible kind application]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are cases where users might want to pass in a wildcard as a visible kind+argument, for instance:++data T :: forall k1 k2. k1 → k2 → Type where+  MkT :: T a b+x :: T @_ @Nat False n+x = MkT++So we should allow '@_' without emitting any hole constraints, and+regardless of whether PartialTypeSignatures is enabled or not. But how would+the typechecker know which '_' is being used in VKA and which is not when it+calls emitNamedWildCardHoleConstraints in tcHsPartialSigType on all HsWildCardBndrs?+The solution then is to neither rename nor include unnamed wildcards in HsWildCardBndrs,+but instead give every anonymous wildcard a fresh wild tyvar in tcAnonWildCardOcc.+And whenever we see a '@', we automatically turn on PartialTypeSignatures and+turn off hole constraint warnings, and do not call emitAnonWildCardHoleConstraint+under these conditions.+See related Note [Wildcards in visible type application] here and+Note [The wildcard story for types] in GHC.Hs.Types++-}++{- *********************************************************************+*                                                                      *+                Tuples+*                                                                      *+********************************************************************* -}++---------------------------+tupKindSort_maybe :: TcKind -> Maybe TupleSort+tupKindSort_maybe k+  | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k'+  | Just k'      <- tcView k            = tupKindSort_maybe k'+  | tcIsConstraintKind k = Just ConstraintTuple+  | tcIsLiftedTypeKind k   = Just BoxedTuple+  | otherwise            = Nothing++tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType+tc_tuple rn_ty mode tup_sort tys exp_kind+  = do { arg_kinds <- case tup_sort of+           BoxedTuple      -> return (replicate arity liftedTypeKind)+           UnboxedTuple    -> replicateM arity newOpenTypeKind+           ConstraintTuple -> return (replicate arity constraintKind)+       ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds+       ; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind }+  where+    arity   = length tys++finish_tuple :: HsType GhcRn+             -> TupleSort+             -> [TcType]    -- ^ argument types+             -> [TcKind]    -- ^ of these kinds+             -> TcKind      -- ^ expected kind of the whole tuple+             -> TcM TcType+finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind = do+  traceTc "finish_tuple" (ppr tup_sort $$ ppr tau_kinds $$ ppr exp_kind)+  case tup_sort of+    ConstraintTuple+      |  [tau_ty] <- tau_tys+         -- Drop any uses of 1-tuple constraints here.+         -- See Note [Ignore unary constraint tuples]+      -> check_expected_kind tau_ty constraintKind+      |  arity > mAX_CTUPLE_SIZE+      -> failWith (bigConstraintTuple arity)+      |  otherwise+      -> do tycon <- tcLookupTyCon (cTupleTyConName arity)+            check_expected_kind (mkTyConApp tycon tau_tys) constraintKind+    BoxedTuple -> do+      let tycon = tupleTyCon Boxed arity+      checkWiredInTyCon tycon+      check_expected_kind (mkTyConApp tycon tau_tys) liftedTypeKind+    UnboxedTuple ->+      let tycon    = tupleTyCon Unboxed arity+          tau_reps = map kindRep tau_kinds+          -- See also Note [Unboxed tuple RuntimeRep vars] in TyCon+          arg_tys  = tau_reps ++ tau_tys+          res_kind = unboxedTupleKind tau_reps in+      check_expected_kind (mkTyConApp tycon arg_tys) res_kind+  where+    arity = length tau_tys+    check_expected_kind ty act_kind =+      checkExpectedKind rn_ty ty act_kind exp_kind++bigConstraintTuple :: Arity -> MsgDoc+bigConstraintTuple arity+  = hang (text "Constraint tuple arity too large:" <+> int arity+          <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))+       2 (text "Instead, use a nested tuple")++{-+Note [Ignore unary constraint tuples]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC provides unary tuples and unboxed tuples (see Note [One-tuples] in+TysWiredIn) but does *not* provide unary constraint tuples. Why? First,+recall the definition of a unary tuple data type:++  data Unit a = Unit a++Note that `Unit a` is *not* the same thing as `a`, since Unit is boxed and+lazy. Therefore, the presence of `Unit` matters semantically. On the other+hand, suppose we had a unary constraint tuple:++  class a => Unit% a++This compiles down a newtype (i.e., a cast) in Core, so `Unit% a` is+semantically equivalent to `a`. Therefore, a 1-tuple constraint would have+no user-visible impact, nor would it allow you to express anything that+you couldn't otherwise.++We could simply add Unit% for consistency with tuples (Unit) and unboxed+tuples (Unit#), but that would require even more magic to wire in another+magical class, so we opt not to do so. We must be careful, however, since+one can try to sneak in uses of unary constraint tuples through Template+Haskell, such as in this program (from #17511):++  f :: $(pure (ForallT [] [TupleT 1 `AppT` (ConT ''Show `AppT` ConT ''Int)]+                       (ConT ''String)))+  -- f :: Unit% (Show Int) => String+  f = "abc"++This use of `TupleT 1` will produce an HsBoxedOrConstraintTuple of arity 1,+and since it is used in a Constraint position, GHC will attempt to treat+it as thought it were a constraint tuple, which can potentially lead to+trouble if one attempts to look up the name of a constraint tuple of arity+1 (as it won't exist). To avoid this trouble, we simply take any unary+constraint tuples discovered when typechecking and drop them—i.e., treat+"Unit% a" as though the user had written "a". This is always safe to do+since the two constraints should be semantically equivalent.+-}++{- *********************************************************************+*                                                                      *+                Type applications+*                                                                      *+********************************************************************* -}++splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn])+splitHsAppTys hs_ty+  | is_app hs_ty = Just (go (noLoc hs_ty) [])+  | otherwise    = Nothing+  where+    is_app :: HsType GhcRn -> Bool+    is_app (HsAppKindTy {})        = True+    is_app (HsAppTy {})            = True+    is_app (HsOpTy _ _ (L _ op) _) = not (op `hasKey` funTyConKey)+      -- I'm not sure why this funTyConKey test is necessary+      -- Can it even happen?  Perhaps for   t1 `(->)` t2+      -- but then maybe it's ok to treat that like a normal+      -- application rather than using the special rule for HsFunTy+    is_app (HsTyVar {})            = True+    is_app (HsParTy _ (L _ ty))    = is_app ty+    is_app _                       = False++    go (L _  (HsAppTy _ f a))      as = go f (HsValArg a : as)+    go (L _  (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as)+    go (L sp (HsParTy _ f))        as = go f (HsArgPar sp : as)+    go (L _  (HsOpTy _ l op@(L sp _) r)) as+      = ( L sp (HsTyVar noExtField NotPromoted op)+        , HsValArg l : HsValArg r : as )+    go f as = (f, as)++---------------------------+tcInferAppHead :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)+-- Version of tc_infer_lhs_type specialised for the head of an+-- application. In particular, for a HsTyVar (which includes type+-- constructors, it does not zoom off into tcInferApps and family+-- saturation+tcInferAppHead mode (L _ (HsTyVar _ _ (L _ tv)))+  = tcTyVar mode tv+tcInferAppHead mode ty+  = tc_infer_lhs_type mode ty++---------------------------+-- | Apply a type of a given kind to a list of arguments. This instantiates+-- invisible parameters as necessary. Always consumes all the arguments,+-- using matchExpectedFunKind as necessary.+-- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.-+-- These kinds should be used to instantiate invisible kind variables;+-- they come from an enclosing class for an associated type/data family.+--+-- tcInferApps also arranges to saturate any trailing invisible arguments+--   of a type-family application, which is usually the right thing to do+-- tcInferApps_nosat does not do this saturation; it is used only+--   by ":kind" in GHCi+tcInferApps, tcInferApps_nosat+    :: TcTyMode+    -> LHsType GhcRn        -- ^ Function (for printing only)+    -> TcType               -- ^ Function+    -> [LHsTypeArg GhcRn]   -- ^ Args+    -> TcM (TcType, TcKind) -- ^ (f args, args, result kind)+tcInferApps mode hs_ty fun hs_args+  = do { (f_args, res_k) <- tcInferApps_nosat mode hs_ty fun hs_args+       ; saturateFamApp f_args res_k }++tcInferApps_nosat mode orig_hs_ty fun orig_hs_args+  = do { traceTc "tcInferApps {" (ppr orig_hs_ty $$ ppr orig_hs_args)+       ; (f_args, res_k) <- go_init 1 fun orig_hs_args+       ; traceTc "tcInferApps }" (ppr f_args <+> dcolon <+> ppr res_k)+       ; return (f_args, res_k) }+  where++    -- go_init just initialises the auxiliary+    -- arguments of the 'go' loop+    go_init n fun all_args+      = go n fun empty_subst fun_ki all_args+      where+        fun_ki = tcTypeKind fun+           -- We do (tcTypeKind fun) here, even though the caller+           -- knows the function kind, to absolutely guarantee+           -- INVARIANT for 'go'+           -- Note that in a typical application (F t1 t2 t3),+           -- the 'fun' is just a TyCon, so tcTypeKind is fast++        empty_subst = mkEmptyTCvSubst $ mkInScopeSet $+                      tyCoVarsOfType fun_ki++    go :: Int             -- The # of the next argument+       -> TcType          -- Function applied to some args+       -> TCvSubst        -- Applies to function kind+       -> TcKind          -- Function kind+       -> [LHsTypeArg GhcRn]    -- Un-type-checked args+       -> TcM (TcType, TcKind)  -- Result type and its kind+    -- INVARIANT: in any call (go n fun subst fun_ki args)+    --               tcTypeKind fun  =  subst(fun_ki)+    -- So the 'subst' and 'fun_ki' arguments are simply+    -- there to avoid repeatedly calling tcTypeKind.+    --+    -- Reason for INVARIANT: to support the Purely Kinded Type Invariant+    -- it's important that if fun_ki has a forall, then so does+    -- (tcTypeKind fun), because the next thing we are going to do+    -- is apply 'fun' to an argument type.++    -- Dispatch on all_args first, for performance reasons+    go n fun subst fun_ki all_args = case (all_args, tcSplitPiTy_maybe fun_ki) of++      ---------------- No user-written args left. We're done!+      ([], _) -> return (fun, substTy subst fun_ki)++      ---------------- HsArgPar: We don't care about parens here+      (HsArgPar _ : args, _) -> go n fun subst fun_ki args++      ---------------- HsTypeArg: a kind application (fun @ki)+      (HsTypeArg _ hs_ki_arg : hs_args, Just (ki_binder, inner_ki)) ->+        case ki_binder of++        -- FunTy with PredTy on LHS, or ForAllTy with Inferred+        Named (Bndr _ Inferred) -> instantiate ki_binder inner_ki+        Anon InvisArg _         -> instantiate ki_binder inner_ki++        Named (Bndr _ Specified) ->  -- Visible kind application+          do { traceTc "tcInferApps (vis kind app)"+                       (vcat [ ppr ki_binder, ppr hs_ki_arg+                             , ppr (tyBinderType ki_binder)+                             , ppr subst ])++             ; let exp_kind = substTy subst $ tyBinderType ki_binder++             ; ki_arg <- addErrCtxt (funAppCtxt orig_hs_ty hs_ki_arg n) $+                         unsetWOptM Opt_WarnPartialTypeSignatures $+                         setXOptM LangExt.PartialTypeSignatures $+                             -- Urgh!  see Note [Wildcards in visible kind application]+                             -- ToDo: must kill this ridiculous messing with DynFlags+                         tc_lhs_type (kindLevel mode) hs_ki_arg exp_kind++             ; traceTc "tcInferApps (vis kind app)" (ppr exp_kind)+             ; (subst', fun') <- mkAppTyM subst fun ki_binder ki_arg+             ; go (n+1) fun' subst' inner_ki hs_args }++        -- Attempted visible kind application (fun @ki), but fun_ki is+        --   forall k -> blah   or   k1 -> k2+        -- So we need a normal application.  Error.+        _ -> ty_app_err hs_ki_arg $ substTy subst fun_ki++      -- No binder; try applying the substitution, or fail if that's not possible+      (HsTypeArg _ ki_arg : _, Nothing) -> try_again_after_substing_or $+                                           ty_app_err ki_arg substed_fun_ki++      ---------------- HsValArg: a nomal argument (fun ty)+      (HsValArg arg : args, Just (ki_binder, inner_ki))+        -- next binder is invisible; need to instantiate it+        | isInvisibleBinder ki_binder   -- FunTy with InvisArg on LHS;+                                        -- or ForAllTy with Inferred or Specified+         -> instantiate ki_binder inner_ki++        -- "normal" case+        | otherwise+         -> do { traceTc "tcInferApps (vis normal app)"+                          (vcat [ ppr ki_binder+                                , ppr arg+                                , ppr (tyBinderType ki_binder)+                                , ppr subst ])+                ; let exp_kind = substTy subst $ tyBinderType ki_binder+                ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $+                          tc_lhs_type mode arg exp_kind+                ; traceTc "tcInferApps (vis normal app) 2" (ppr exp_kind)+                ; (subst', fun') <- mkAppTyM subst fun ki_binder arg'+                ; go (n+1) fun' subst' inner_ki args }++          -- no binder; try applying the substitution, or infer another arrow in fun kind+      (HsValArg _ : _, Nothing)+        -> try_again_after_substing_or $+           do { let arrows_needed = n_initial_val_args all_args+              ; co <- matchExpectedFunKind hs_ty arrows_needed substed_fun_ki++              ; fun' <- zonkTcType (fun `mkTcCastTy` co)+                     -- This zonk is essential, to expose the fruits+                     -- of matchExpectedFunKind to the 'go' loop++              ; traceTc "tcInferApps (no binder)" $+                   vcat [ ppr fun <+> dcolon <+> ppr fun_ki+                        , ppr arrows_needed+                        , ppr co+                        , ppr fun' <+> dcolon <+> ppr (tcTypeKind fun')]+              ; go_init n fun' all_args }+                -- Use go_init to establish go's INVARIANT+      where+        instantiate ki_binder inner_ki+          = do { traceTc "tcInferApps (need to instantiate)"+                         (vcat [ ppr ki_binder, ppr subst])+               ; (subst', arg') <- tcInstInvisibleTyBinder subst ki_binder+               ; go n (mkAppTy fun arg') subst' inner_ki all_args }+                 -- Because tcInvisibleTyBinder instantiate ki_binder,+                 -- the kind of arg' will have the same shape as the kind+                 -- of ki_binder.  So we don't need mkAppTyM here.++        try_again_after_substing_or fallthrough+          | not (isEmptyTCvSubst subst)+          = go n fun zapped_subst substed_fun_ki all_args+          | otherwise+          = fallthrough++        zapped_subst   = zapTCvSubst subst+        substed_fun_ki = substTy subst fun_ki+        hs_ty          = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args)++    n_initial_val_args :: [HsArg tm ty] -> Arity+    -- Count how many leading HsValArgs we have+    n_initial_val_args (HsValArg {} : args) = 1 + n_initial_val_args args+    n_initial_val_args (HsArgPar {} : args) = n_initial_val_args args+    n_initial_val_args _                    = 0++    ty_app_err arg ty+      = failWith $ text "Cannot apply function of kind" <+> quotes (ppr ty)+                $$ text "to visible kind argument" <+> quotes (ppr arg)+++mkAppTyM :: TCvSubst+         -> TcType -> TyCoBinder    -- fun, plus its top-level binder+         -> TcType                  -- arg+         -> TcM (TCvSubst, TcType)  -- Extended subst, plus (fun arg)+-- Precondition: the application (fun arg) is well-kinded after zonking+--               That is, the application makes sense+--+-- Precondition: for (mkAppTyM subst fun bndr arg)+--       tcTypeKind fun  =  Pi bndr. body+--  That is, fun always has a ForAllTy or FunTy at the top+--           and 'bndr' is fun's pi-binder+--+-- Postcondition: if fun and arg satisfy (PKTI), the purely-kinded type+--                invariant, then so does the result type (fun arg)+--+-- We do not require that+--    tcTypeKind arg = tyVarKind (binderVar bndr)+-- This must be true after zonking (precondition 1), but it's not+-- required for the (PKTI).+mkAppTyM subst fun ki_binder arg+  | -- See Note [mkAppTyM]: Nasty case 2+    TyConApp tc args <- fun+  , isTypeSynonymTyCon tc+  , args `lengthIs` (tyConArity tc - 1)+  , any isTrickyTvBinder (tyConTyVars tc) -- We could cache this in the synonym+  = do { arg'  <- zonkTcType  arg+       ; args' <- zonkTcTypes args+       ; let subst' = case ki_binder of+                        Anon {}           -> subst+                        Named (Bndr tv _) -> extendTvSubstAndInScope subst tv arg'+       ; return (subst', mkTyConApp tc (args' ++ [arg'])) }+++mkAppTyM subst fun (Anon {}) arg+   = return (subst, mk_app_ty fun arg)++mkAppTyM subst fun (Named (Bndr tv _)) arg+  = do { arg' <- if isTrickyTvBinder tv+                 then -- See Note [mkAppTyM]: Nasty case 1+                      zonkTcType arg+                 else return     arg+       ; return ( extendTvSubstAndInScope subst tv arg'+                , mk_app_ty fun arg' ) }++mk_app_ty :: TcType -> TcType -> TcType+-- This function just adds an ASSERT for mkAppTyM's precondition+mk_app_ty fun arg+  = ASSERT2( isPiTy fun_kind+           ,  ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg )+    mkAppTy fun arg+  where+    fun_kind = tcTypeKind fun++isTrickyTvBinder :: TcTyVar -> Bool+-- NB: isTrickyTvBinder is just an optimisation+-- It would be absolutely sound to return True always+isTrickyTvBinder tv = isPiTy (tyVarKind tv)++{- Note [The Purely Kinded Type Invariant (PKTI)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+During type inference, we maintain this invariant++ (PKTI) It is legal to call 'tcTypeKind' on any Type ty,+        on any sub-term of ty, /without/ zonking ty++        Moreover, any such returned kind+        will itself satisfy (PKTI)++By "legal to call tcTypeKind" we mean "tcTypeKind will not crash".+The way in which tcTypeKind can crash is in applications+    (a t1 t2 .. tn)+if 'a' is a type variable whose kind doesn't have enough arrows+or foralls.  (The crash is in piResultTys.)++The loop in tcInferApps has to be very careful to maintain the (PKTI).+For example, suppose+    kappa is a unification variable+    We have already unified kappa := Type+      yielding    co :: Refl (Type -> Type)+    a :: kappa+then consider the type+    (a Int)+If we call tcTypeKind on that, we'll crash, because the (un-zonked)+kind of 'a' is just kappa, not an arrow kind.  So we must zonk first.++So the type inference engine is very careful when building applications.+This happens in tcInferApps. Suppose we are kind-checking the type (a Int),+where (a :: kappa).  Then in tcInferApps we'll run out of binders on+a's kind, so we'll call matchExpectedFunKind, and unify+   kappa := kappa1 -> kappa2,  with evidence co :: kappa ~ (kappa1 ~ kappa2)+At this point we must zonk the function type to expose the arrrow, so+that (a Int) will satisfy (PKTI).++The absence of this caused #14174 and #14520.++The calls to mkAppTyM is the other place we are very careful.++Note [mkAppTyM]+~~~~~~~~~~~~~~~+mkAppTyM is trying to guarantee the Purely Kinded Type Invariant+(PKTI) for its result type (fun arg).  There are two ways it can go wrong:++* Nasty case 1: forall types (polykinds/T14174a)+    T :: forall (p :: *->*). p Int -> p Bool+  Now kind-check (T x), where x::kappa.+  Well, T and x both satisfy the PKTI, but+     T x :: x Int -> x Bool+  and (x Int) does /not/ satisfy the PKTI.++* Nasty case 2: type synonyms+    type S f a = f a+  Even though (S ff aa) would satisfy the (PKTI) if S was a data type+  (i.e. nasty case 1 is dealt with), it might still not satisfy (PKTI)+  if S is a type synonym, because the /expansion/ of (S ff aa) is+  (ff aa), and /that/ does not satisfy (PKTI).  E.g. perhaps+  (ff :: kappa), where 'kappa' has already been unified with (*->*).++  We check for nasty case 2 on the final argument of a type synonym.++Notice that in both cases the trickiness only happens if the+bound variable has a pi-type.  Hence isTrickyTvBinder.+-}+++saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind)+-- Precondition for (saturateFamApp ty kind):+--     tcTypeKind ty = kind+--+-- If 'ty' is an unsaturated family application wtih trailing+-- invisible arguments, instanttiate them.+-- See Note [saturateFamApp]++saturateFamApp ty kind+  | Just (tc, args) <- tcSplitTyConApp_maybe ty+  , mustBeSaturated tc+  , let n_to_inst = tyConArity tc - length args+  = do { (extra_args, ki') <- tcInstInvisibleTyBinders n_to_inst kind+       ; return (ty `mkTcAppTys` extra_args, ki') }+  | otherwise+  = return (ty, kind)++{- Note [saturateFamApp]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   type family F :: Either j k+   type instance F @Type = Right Maybe+   type instance F @Type = Right Either```++Then F :: forall {j,k}. Either j k++The two type instances do a visible kind application that instantiates+'j' but not 'k'.  But we want to end up with instances that look like+  type instance F @Type @(*->*) = Right @Type @(*->*) Maybe++so that F has arity 2.  We must instantiate that trailing invisible+binder. In general, Invisible binders precede Specified and Required,+so this is only going to bite for apparently-nullary families.++Note that+  type family F2 :: forall k. k -> *+is quite different and really does have arity 0.++It's not just type instances where we need to saturate those+unsaturated arguments: see #11246.  Hence doing this in tcInferApps.+-}++appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn+appTypeToArg f []                       = f+appTypeToArg f (HsValArg arg    : args) = appTypeToArg (mkHsAppTy f arg) args+appTypeToArg f (HsArgPar _      : args) = appTypeToArg f                 args+appTypeToArg f (HsTypeArg l arg : args)+  = appTypeToArg (mkHsAppKindTy l f arg) args+++{- *********************************************************************+*                                                                      *+                checkExpectedKind+*                                                                      *+********************************************************************* -}++-- | This instantiates invisible arguments for the type being checked if it must+-- be saturated and is not yet saturated. It then calls and uses the result+-- from checkExpectedKindX to build the final type+checkExpectedKind :: HasDebugCallStack+                  => HsType GhcRn       -- ^ type we're checking (for printing)+                  -> TcType             -- ^ type we're checking+                  -> TcKind             -- ^ the known kind of that type+                  -> TcKind             -- ^ the expected kind+                  -> TcM TcType+-- Just a convenience wrapper to save calls to 'ppr'+checkExpectedKind hs_ty ty act exp+  = checkExpectedKind_pp (ppr hs_ty) ty act exp++checkExpectedKind_pp :: HasDebugCallStack+                     => SDoc               -- ^ The thing we are checking+                     -> TcType             -- ^ type we're checking+                     -> TcKind             -- ^ the known kind of that type+                     -> TcKind             -- ^ the expected kind+                     -> TcM TcType+checkExpectedKind_pp pp_hs_ty ty act_kind exp_kind+  = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind)++       ; (new_args, act_kind') <- tcInstInvisibleTyBinders n_to_inst act_kind++       ; let origin = TypeEqOrigin { uo_actual   = act_kind'+                                   , uo_expected = exp_kind+                                   , uo_thing    = Just pp_hs_ty+                                   , uo_visible  = True } -- the hs_ty is visible++       ; traceTc "checkExpectedKindX" $+         vcat [ pp_hs_ty+              , text "act_kind':" <+> ppr act_kind'+              , text "exp_kind:" <+> ppr exp_kind ]++       ; let res_ty = ty `mkTcAppTys` new_args++       ; if act_kind' `tcEqType` exp_kind+         then return res_ty  -- This is very common+         else do { co_k <- uType KindLevel origin act_kind' exp_kind+                 ; traceTc "checkExpectedKind" (vcat [ ppr act_kind+                                                     , ppr exp_kind+                                                     , ppr co_k ])+                ; return (res_ty `mkTcCastTy` co_k) } }+    where+      -- We need to make sure that both kinds have the same number of implicit+      -- foralls out front. If the actual kind has more, instantiate accordingly.+      -- Otherwise, just pass the type & kind through: the errors are caught+      -- in unifyType.+      n_exp_invis_bndrs = invisibleTyBndrCount exp_kind+      n_act_invis_bndrs = invisibleTyBndrCount act_kind+      n_to_inst         = n_act_invis_bndrs - n_exp_invis_bndrs+++---------------------------+tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]+tcHsMbContext Nothing    = return []+tcHsMbContext (Just cxt) = tcHsContext cxt++tcHsContext :: LHsContext GhcRn -> TcM [PredType]+tcHsContext = tc_hs_context typeLevelMode++tcLHsPredType :: LHsType GhcRn -> TcM PredType+tcLHsPredType = tc_lhs_pred typeLevelMode++tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType]+tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt)++tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType+tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind++---------------------------+tcTyVar :: TcTyMode -> Name -> TcM (TcType, TcKind)+-- See Note [Type checking recursive type and class declarations]+-- in TcTyClsDecls+tcTyVar mode name         -- Could be a tyvar, a tycon, or a datacon+  = do { traceTc "lk1" (ppr name)+       ; thing <- tcLookup name+       ; case thing of+           ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv)++           ATcTyCon tc_tc+             -> do { -- See Note [GADT kind self-reference]+                     unless (isTypeLevel (mode_level mode))+                            (promotionErr name TyConPE)+                   ; check_tc tc_tc+                   ; return (mkTyConTy tc_tc, tyConKind tc_tc) }++           AGlobal (ATyCon tc)+             -> do { check_tc tc+                   ; return (mkTyConTy tc, tyConKind tc) }++           AGlobal (AConLike (RealDataCon dc))+             -> do { data_kinds <- xoptM LangExt.DataKinds+                   ; unless (data_kinds || specialPromotedDc dc) $+                       promotionErr name NoDataKindsDC+                   ; when (isFamInstTyCon (dataConTyCon dc)) $+                       -- see #15245+                       promotionErr name FamDataConPE+                   ; let (_, _, _, theta, _, _) = dataConFullSig dc+                   ; traceTc "tcTyVar" (ppr dc <+> ppr theta $$ ppr (dc_theta_illegal_constraint theta))+                   ; case dc_theta_illegal_constraint theta of+                       Just pred -> promotionErr name $+                                    ConstrainedDataConPE pred+                       Nothing   -> pure ()+                   ; let tc = promoteDataCon dc+                   ; return (mkTyConApp tc [], tyConKind tc) }++           APromotionErr err -> promotionErr name err++           _  -> wrongThingErr "type" thing name }+  where+    check_tc :: TyCon -> TcM ()+    check_tc tc = do { data_kinds   <- xoptM LangExt.DataKinds+                     ; unless (isTypeLevel (mode_level mode) ||+                               data_kinds ||+                               isKindTyCon tc) $+                       promotionErr name NoDataKindsTC }++    -- We cannot promote a data constructor with a context that contains+    -- constraints other than equalities, so error if we find one.+    -- See Note [Constraints in kinds] in TyCoRep+    dc_theta_illegal_constraint :: ThetaType -> Maybe PredType+    dc_theta_illegal_constraint = find (not . isEqPred)++{-+Note [GADT kind self-reference]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++A promoted type cannot be used in the body of that type's declaration.+#11554 shows this example, which made GHC loop:++  import Data.Kind+  data P (x :: k) = Q+  data A :: Type where+    B :: forall (a :: A). P a -> A++In order to check the constructor B, we need to have the promoted type A, but in+order to get that promoted type, B must first be checked. To prevent looping, a+TyConPE promotion error is given when tcTyVar checks an ATcTyCon in kind mode.+Any ATcTyCon is a TyCon being defined in the current recursive group (see data+type decl for TcTyThing), and all such TyCons are illegal in kinds.++#11962 proposes checking the head of a data declaration separately from+its constructors. This would allow the example above to pass.++Note [Body kind of a HsForAllTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The body of a forall is usually a type, but in principle+there's no reason to prohibit *unlifted* types.+In fact, GHC can itself construct a function with an+unboxed tuple inside a for-all (via CPR analysis; see+typecheck/should_compile/tc170).++Moreover in instance heads we get forall-types with+kind Constraint.++It's tempting to check that the body kind is either * or #. But this is+wrong. For example:++  class C a b+  newtype N = Mk Foo deriving (C a)++We're doing newtype-deriving for C. But notice how `a` isn't in scope in+the predicate `C a`. So we quantify, yielding `forall a. C a` even though+`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but+convenient. Bottom line: don't check for * or # here.++Note [Body kind of a HsQualTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If ctxt is non-empty, the HsQualTy really is a /function/, so the+kind of the result really is '*', and in that case the kind of the+body-type can be lifted or unlifted.++However, consider+    instance Eq a => Eq [a] where ...+or+    f :: (Eq a => Eq [a]) => blah+Here both body-kind of the HsQualTy is Constraint rather than *.+Rather crudely we tell the difference by looking at exp_kind. It's+very convenient to typecheck instance types like any other HsSigType.++Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's+better to reject in checkValidType.  If we say that the body kind+should be '*' we risk getting TWO error messages, one saying that Eq+[a] doens't have kind '*', and one saying that we need a Constraint to+the left of the outer (=>).++How do we figure out the right body kind?  Well, it's a bit of a+kludge: I just look at the expected kind.  If it's Constraint, we+must be in this instance situation context. It's a kludge because it+wouldn't work if any unification was involved to compute that result+kind -- but it isn't.  (The true way might be to use the 'mode'+parameter, but that seemed like a sledgehammer to crack a nut.)++Note [Inferring tuple kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple,+we try to figure out whether it's a tuple of kind * or Constraint.+  Step 1: look at the expected kind+  Step 2: infer argument kinds++If after Step 2 it's not clear from the arguments that it's+Constraint, then it must be *.  Once having decided that we re-check+the arguments to give good error messages in+  e.g.  (Maybe, Maybe)++Note that we will still fail to infer the correct kind in this case:++  type T a = ((a,a), D a)+  type family D :: Constraint -> Constraint++While kind checking T, we do not yet know the kind of D, so we will default the+kind of T to * -> *. It works if we annotate `a` with kind `Constraint`.++Note [Desugaring types]+~~~~~~~~~~~~~~~~~~~~~~~+The type desugarer is phase 2 of dealing with HsTypes.  Specifically:++  * It transforms from HsType to Type++  * It zonks any kinds.  The returned type should have no mutable kind+    or type variables (hence returning Type not TcType):+      - any unconstrained kind variables are defaulted to (Any *) just+        as in TcHsSyn.+      - there are no mutable type variables because we are+        kind-checking a type+    Reason: the returned type may be put in a TyCon or DataCon where+    it will never subsequently be zonked.++You might worry about nested scopes:+        ..a:kappa in scope..+            let f :: forall b. T '[a,b] -> Int+In this case, f's type could have a mutable kind variable kappa in it;+and we might then default it to (Any *) when dealing with f's type+signature.  But we don't expect this to happen because we can't get a+lexically scoped type variable with a mutable kind variable in it.  A+delicate point, this.  If it becomes an issue we might need to+distinguish top-level from nested uses.++Moreover+  * it cannot fail,+  * it does no unifications+  * it does no validity checking, except for structural matters, such as+        (a) spurious ! annotations.+        (b) a class used as a type++Note [Kind of a type splice]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these terms, each with TH type splice inside:+     [| e1 :: Maybe $(..blah..) |]+     [| e2 :: $(..blah..) |]+When kind-checking the type signature, we'll kind-check the splice+$(..blah..); we want to give it a kind that can fit in any context,+as if $(..blah..) :: forall k. k.++In the e1 example, the context of the splice fixes kappa to *.  But+in the e2 example, we'll desugar the type, zonking the kind unification+variables as we go.  When we encounter the unconstrained kappa, we+want to default it to '*', not to (Any *).++Help functions for type applications+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-}++addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a+        -- Wrap a context around only if we want to show that contexts.+        -- Omit invisible ones and ones user's won't grok+addTypeCtxt (L _ (HsWildCardTy _)) thing = thing   -- "In the type '_'" just isn't helpful.+addTypeCtxt (L _ ty) thing+  = addErrCtxt doc thing+  where+    doc = text "In the type" <+> quotes (ppr ty)++{-+************************************************************************+*                                                                      *+                Type-variable binders+%*                                                                      *+%************************************************************************++Note [Keeping scoped variables in order: Explicit]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the user writes `forall a b c. blah`, we bring a, b, and c into+scope and then check blah. In the process of checking blah, we might+learn the kinds of a, b, and c, and these kinds might indicate that+b depends on c, and thus that we should reject the user-written type.++One approach to doing this would be to bring each of a, b, and c into+scope, one at a time, creating an implication constraint and+bumping the TcLevel for each one. This would work, because the kind+of, say, b would be untouchable when c is in scope (and the constraint+couldn't float out because c blocks it). However, it leads to terrible+error messages, complaining about skolem escape. While it is indeed+a problem of skolem escape, we can do better.++Instead, our approach is to bring the block of variables into scope+all at once, creating one implication constraint for the lot. The+user-written variables are skolems in the implication constraint. In+TcSimplify.setImplicationStatus, we check to make sure that the ordering+is correct, choosing ImplicationStatus IC_BadTelescope if they aren't.+Then, in TcErrors, we report if there is a bad telescope. This way,+we can report a suggested ordering to the user if there is a problem.++See also Note [Checking telescopes] in Constraint++Note [Keeping scoped variables in order: Implicit]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the user implicitly quantifies over variables (say, in a type+signature), we need to come up with some ordering on these variables.+This is done by bumping the TcLevel, bringing the tyvars into scope,+and then type-checking the thing_inside. The constraints are all+wrapped in an implication, which is then solved. Finally, we can+zonk all the binders and then order them with scopedSort.++It's critical to solve before zonking and ordering in order to uncover+any unifications. You might worry that this eager solving could cause+trouble elsewhere. I don't think it will. Because it will solve only+in an increased TcLevel, it can't unify anything that was mentioned+elsewhere. Additionally, we require that the order of implicitly+quantified variables is manifest by the scope of these variables, so+we're not going to learn more information later that will help order+these variables.++Note [Recipe for checking a signature]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Checking a user-written signature requires several steps:++ 1. Generate constraints.+ 2. Solve constraints.+ 3. Promote tyvars and/or kind-generalize.+ 4. Zonk.+ 5. Check validity.++There may be some surprises in here:++Step 2 is necessary for two reasons: most signatures also bring+implicitly quantified variables into scope, and solving is necessary+to get these in the right order (see Note [Keeping scoped variables in+order: Implicit]). Additionally, solving is necessary in order to+kind-generalize correctly: otherwise, we do not know which metavariables+are left unsolved.++Step 3 is done by a call to candidateQTyVarsOfType, followed by a call to+kindGeneralize{All,Some,None}. Here, we have to deal with the fact that+metatyvars generated in the type may have a bumped TcLevel, because explicit+foralls raise the TcLevel. To avoid these variables from ever being visible in+the surrounding context, we must obey the following dictum:++  Every metavariable in a type must either be+    (A) generalized, or+    (B) promoted, or        See Note [Promotion in signatures]+    (C) zapped to Any       See Note [Naughty quantification candidates] in TcMType++The kindGeneralize functions do not require pre-zonking; they zonk as they+go.++If you are actually doing kind-generalization, you need to bump the level+before generating constraints, as we will only generalize variables with+a TcLevel higher than the ambient one.++After promoting/generalizing, we need to zonk again because both+promoting and generalizing fill in metavariables.++Note [Promotion in signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If an unsolved metavariable in a signature is not generalized+(because we're not generalizing the construct -- e.g., pattern+sig -- or because the metavars are constrained -- see kindGeneralizeSome)+we need to promote to maintain (MetaTvInv) of Note [TcLevel and untouchable type variables]+in TcType. Note that promotion is identical in effect to generalizing+and the reinstantiating with a fresh metavariable at the current level.+So in some sense, we generalize *all* variables, but then re-instantiate+some of them.++Here is an example of why we must promote:+  foo (x :: forall a. a -> Proxy b) = ...++In the pattern signature, `b` is unbound, and will thus be brought into+scope. We do not know its kind: it will be assigned kappa[2]. Note that+kappa is at TcLevel 2, because it is invented under a forall. (A priori,+the kind kappa might depend on `a`, so kappa rightly has a higher TcLevel+than the surrounding context.) This kappa cannot be solved for while checking+the pattern signature (which is not kind-generalized). When we are checking+the *body* of foo, though, we need to unify the type of x with the argument+type of bar. At this point, the ambient TcLevel is 1, and spotting a+matavariable with level 2 would violate the (MetaTvInv) invariant of+Note [TcLevel and untouchable type variables]. So, instead of kind-generalizing,+we promote the metavariable to level 1. This is all done in kindGeneralizeNone.++-}++tcNamedWildCardBinders :: [Name]+                       -> ([(Name, TcTyVar)] -> TcM a)+                       -> TcM a+-- Bring into scope the /named/ wildcard binders.  Remember that+-- plain wildcards _ are anonymous and dealt with by HsWildCardTy+-- Soe Note [The wildcard story for types] in GHC.Hs.Types+tcNamedWildCardBinders wc_names thing_inside+  = do { wcs <- mapM (const newWildTyVar) wc_names+       ; let wc_prs = wc_names `zip` wcs+       ; tcExtendNameTyVarEnv wc_prs $+         thing_inside wc_prs }++newWildTyVar :: TcM TcTyVar+-- ^ New unification variable '_' for a wildcard+newWildTyVar+  = do { kind <- newMetaKindVar+       ; uniq <- newUnique+       ; details <- newMetaDetails TauTv+       ; let name  = mkSysTvName uniq (fsLit "_")+             tyvar = mkTcTyVar name kind details+       ; traceTc "newWildTyVar" (ppr tyvar)+       ; return tyvar }++{- *********************************************************************+*                                                                      *+             Kind inference for type declarations+*                                                                      *+********************************************************************* -}++-- See Note [kcCheckDeclHeader vs kcInferDeclHeader]+data InitialKindStrategy+  = InitialKindCheck SAKS_or_CUSK+  | InitialKindInfer++-- Does the declaration have a standalone kind signature (SAKS) or a complete+-- user-specified kind (CUSK)?+data SAKS_or_CUSK+  = SAKS Kind  -- Standalone kind signature, fully zonked! (zonkTcTypeToType)+  | CUSK       -- Complete user-specified kind (CUSK)++instance Outputable SAKS_or_CUSK where+  ppr (SAKS k) = text "SAKS" <+> ppr k+  ppr CUSK = text "CUSK"++-- See Note [kcCheckDeclHeader vs kcInferDeclHeader]+kcDeclHeader+  :: InitialKindStrategy+  -> Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn  -- ^ Binders in the header+  -> TcM ContextKind   -- ^ The result kind+  -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon+kcDeclHeader (InitialKindCheck msig) = kcCheckDeclHeader msig+kcDeclHeader InitialKindInfer = kcInferDeclHeader++{- Note [kcCheckDeclHeader vs kcInferDeclHeader]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+kcCheckDeclHeader and kcInferDeclHeader are responsible for getting the initial kind+of a type constructor.++* kcCheckDeclHeader: the TyCon has a standalone kind signature or a CUSK. In that+  case, find the full, final, poly-kinded kind of the TyCon.  It's very like a+  term-level binding where we have a complete type signature for the function.++* kcInferDeclHeader: the TyCon has neither a standalone kind signature nor a+  CUSK. Find a monomorphic kind, with unification variables in it; they will be+  generalised later.  It's very like a term-level binding where we do not have a+  type signature (or, more accurately, where we have a partial type signature),+  so we infer the type and generalise.+-}++------------------------------+kcCheckDeclHeader+  :: SAKS_or_CUSK+  -> Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn  -- ^ Binders in the header+  -> TcM ContextKind   -- ^ The result kind. AnyKind == no result signature+  -> TcM TcTyCon       -- ^ A suitably-kinded generalized TcTyCon+kcCheckDeclHeader (SAKS sig) = kcCheckDeclHeader_sig sig+kcCheckDeclHeader CUSK       = kcCheckDeclHeader_cusk++kcCheckDeclHeader_cusk+  :: Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn  -- ^ Binders in the header+  -> TcM ContextKind   -- ^ The result kind+  -> TcM TcTyCon       -- ^ A suitably-kinded generalized TcTyCon+kcCheckDeclHeader_cusk name flav+              (HsQTvs { hsq_ext = kv_ns+                      , hsq_explicit = hs_tvs }) kc_res_ki+  -- CUSK case+  -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls+  = addTyConFlavCtxt name flav $+    do { (scoped_kvs, (tc_tvs, res_kind))+           <- pushTcLevelM_                               $+              solveEqualities                             $+              bindImplicitTKBndrs_Q_Skol kv_ns            $+              bindExplicitTKBndrs_Q_Skol ctxt_kind hs_tvs $+              newExpectedKind =<< kc_res_ki++           -- Now, because we're in a CUSK,+           -- we quantify over the mentioned kind vars+       ; let spec_req_tkvs = scoped_kvs ++ tc_tvs+             all_kinds     = res_kind : map tyVarKind spec_req_tkvs++       ; candidates' <- candidateQTyVarsOfKinds all_kinds+             -- 'candidates' are all the variables that we are going to+             -- skolemise and then quantify over.  We do not include spec_req_tvs+             -- because they are /already/ skolems++       ; let non_tc_candidates = filter (not . isTcTyVar) (nonDetEltsUniqSet (tyCoVarsOfTypes all_kinds))+             candidates = candidates' { dv_kvs = dv_kvs candidates' `extendDVarSetList` non_tc_candidates }+             inf_candidates = candidates `delCandidates` spec_req_tkvs++       ; inferred <- quantifyTyVars inf_candidates+                     -- NB: 'inferred' comes back sorted in dependency order++       ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs+       ; tc_tvs     <- mapM zonkTyCoVarKind tc_tvs+       ; res_kind   <- zonkTcType           res_kind++       ; let mentioned_kv_set = candidateKindVars candidates+             specified        = scopedSort scoped_kvs+                                -- NB: maintain the L-R order of scoped_kvs++             final_tc_binders =  mkNamedTyConBinders Inferred  inferred+                              ++ mkNamedTyConBinders Specified specified+                              ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs++             all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)+             tycon = mkTcTyCon name final_tc_binders res_kind all_tv_prs+                               True -- it is generalised+                               flav+         -- If the ordering from+         -- Note [Required, Specified, and Inferred for types] in TcTyClsDecls+         -- doesn't work, we catch it here, before an error cascade+       ; checkTyConTelescope tycon++       ; traceTc "kcCheckDeclHeader_cusk " $+         vcat [ text "name" <+> ppr name+              , text "kv_ns" <+> ppr kv_ns+              , text "hs_tvs" <+> ppr hs_tvs+              , text "scoped_kvs" <+> ppr scoped_kvs+              , text "tc_tvs" <+> ppr tc_tvs+              , text "res_kind" <+> ppr res_kind+              , text "candidates" <+> ppr candidates+              , text "inferred" <+> ppr inferred+              , text "specified" <+> ppr specified+              , text "final_tc_binders" <+> ppr final_tc_binders+              , text "mkTyConKind final_tc_bndrs res_kind"+                <+> ppr (mkTyConKind final_tc_binders res_kind)+              , text "all_tv_prs" <+> ppr all_tv_prs ]++       ; return tycon }+  where+    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind+              | otherwise            = AnyKind+kcCheckDeclHeader_cusk _ _ (XLHsQTyVars nec) _ = noExtCon nec++-- | Kind-check a 'LHsQTyVars'. Used in 'inferInitialKind' (for tycon kinds and+-- other kinds).+--+-- This function does not do telescope checking.+kcInferDeclHeader+  :: Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn+  -> TcM ContextKind   -- ^ The result kind+  -> TcM TcTyCon       -- ^ A suitably-kinded non-generalized TcTyCon+kcInferDeclHeader name flav+              (HsQTvs { hsq_ext = kv_ns+                      , hsq_explicit = hs_tvs }) kc_res_ki+  -- No standalane kind signature and no CUSK.+  -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls+  = do { (scoped_kvs, (tc_tvs, res_kind))+           -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar?+           -- See Note [Inferring kinds for type declarations] in TcTyClsDecls+           <- bindImplicitTKBndrs_Q_Tv kv_ns            $+              bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $+              newExpectedKind =<< kc_res_ki+              -- Why "_Tv" not "_Skol"? See third wrinkle in+              -- Note [Inferring kinds for type declarations] in TcTyClsDecls,++       ; let   -- NB: Don't add scoped_kvs to tyConTyVars, because they+               -- might unify with kind vars in other types in a mutually+               -- recursive group.+               -- See Note [Inferring kinds for type declarations] in TcTyClsDecls++             tc_binders = mkAnonTyConBinders VisArg tc_tvs+               -- Also, note that tc_binders has the tyvars from only the+               -- user-written tyvarbinders. See S1 in Note [How TcTyCons work]+               -- in TcTyClsDecls+               --+               -- mkAnonTyConBinder: see Note [No polymorphic recursion]++             all_tv_prs = (kv_ns                `zip` scoped_kvs) +++                          (hsLTyVarNames hs_tvs `zip` tc_tvs)+               -- NB: bindIplicitTKBndrs_Q_Tv makes /freshly-named/ unification+               --     variables, hence the need to zip here.  Ditto bindExplicit..+               -- See TcMType Note [Unification variables need fresh Names]++             tycon = mkTcTyCon name tc_binders res_kind all_tv_prs+                               False -- not yet generalised+                               flav++       ; traceTc "kcInferDeclHeader: not-cusk" $+         vcat [ ppr name, ppr kv_ns, ppr hs_tvs+              , ppr scoped_kvs+              , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ]+       ; return tycon }+  where+    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind+              | otherwise            = AnyKind++kcInferDeclHeader _ _ (XLHsQTyVars nec) _ = noExtCon nec++-- | Kind-check a declaration header against a standalone kind signature.+-- See Note [Arity inference in kcCheckDeclHeader_sig]+kcCheckDeclHeader_sig+  :: Kind              -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType)+  -> Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn  -- ^ Binders in the header+  -> TcM ContextKind   -- ^ The result kind. AnyKind == no result signature+  -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon+kcCheckDeclHeader_sig kisig name flav ktvs kc_res_ki =+  addTyConFlavCtxt name flav $+    pushTcLevelM_ $+    solveEqualities $  -- #16687+    bind_implicit (hsq_ext ktvs) $ \implicit_tcv_prs -> do++      -- Step 1: zip user-written binders with quantifiers from the kind signature.+      -- For example:+      --+      --   type F :: forall k -> k -> forall j. j -> Type+      --   data F i a b = ...+      --+      -- Results in the following 'zipped_binders':+      --+      --                   TyBinder      LHsTyVarBndr+      --    ---------------------------------------+      --    ZippedBinder   forall k ->   i+      --    ZippedBinder   k ->          a+      --    ZippedBinder   forall j.+      --    ZippedBinder   j ->          b+      --+      let (zipped_binders, excess_bndrs, kisig') = zipBinders kisig (hsq_explicit ktvs)++      -- Report binders that don't have a corresponding quantifier.+      -- For example:+      --+      --   type T :: Type -> Type+      --   data T b1 b2 b3 = ...+      --+      -- Here, b1 is zipped with Type->, while b2 and b3 are excess binders.+      --+      unless (null excess_bndrs) $ failWithTc (tooManyBindersErr kisig' excess_bndrs)++      -- Convert each ZippedBinder to TyConBinder        for  tyConBinders+      --                       and to [(Name, TcTyVar)]  for  tcTyConScopedTyVars+      (vis_tcbs, concat -> explicit_tv_prs) <- mapAndUnzipM zipped_to_tcb zipped_binders++      tcExtendNameTyVarEnv explicit_tv_prs $ do++        -- Check that inline kind annotations on binders are valid.+        -- For example:+        --+        --   type T :: Maybe k -> Type+        --   data T (a :: Maybe j) = ...+        --+        -- Here we unify   Maybe k ~ Maybe j+        mapM_ check_zipped_binder zipped_binders++        -- Kind-check the result kind annotation, if present:+        --+        --    data T a b :: res_ki where+        --               ^^^^^^^^^+        -- We do it here because at this point the environment has been+        -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'.+        m_res_ki <- kc_res_ki >>= \ctx_k ->+          case ctx_k of+            AnyKind -> return Nothing+            _ -> Just <$> newExpectedKind ctx_k++        -- Step 2: split off invisible binders.+        -- For example:+        --+        --   type F :: forall k1 k2. (k1, k2) -> Type+        --   type family F+        --+        -- Does 'forall k1 k2' become a part of 'tyConBinders' or 'tyConResKind'?+        -- See Note [Arity inference in kcCheckDeclHeader_sig]+        let (invis_binders, r_ki) = split_invis kisig' m_res_ki++        -- Convert each invisible TyCoBinder to TyConBinder for tyConBinders.+        invis_tcbs <- mapM invis_to_tcb invis_binders++        -- Check that the inline result kind annotation is valid.+        -- For example:+        --+        --   type T :: Type -> Maybe k+        --   type family T a :: Maybe j where+        --+        -- Here we unify   Maybe k ~ Maybe j+        whenIsJust m_res_ki $ \res_ki ->+          discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig]+          unifyKind Nothing r_ki res_ki++        -- Zonk the implicitly quantified variables.+        implicit_tv_prs <- mapSndM zonkTcTyVarToTyVar implicit_tcv_prs++        -- Build the final, generalized TcTyCon+        let tcbs       = vis_tcbs ++ invis_tcbs+            all_tv_prs = implicit_tv_prs ++ explicit_tv_prs+            tc = mkTcTyCon name tcbs r_ki all_tv_prs True flav++        traceTc "kcCheckDeclHeader_sig done:" $ vcat+          [ text "tyConName = " <+> ppr (tyConName tc)+          , text "kisig =" <+> debugPprType kisig+          , text "tyConKind =" <+> debugPprType (tyConKind tc)+          , text "tyConBinders = " <+> ppr (tyConBinders tc)+          , text "tcTyConScopedTyVars" <+> ppr (tcTyConScopedTyVars tc)+          , text "tyConResKind" <+> debugPprType (tyConResKind tc)+          ]+        return tc+  where+    -- Consider this declaration:+    --+    --    type T :: forall a. forall b -> (a~b) => Proxy a -> Type+    --    data T x p = MkT+    --+    -- Here, we have every possible variant of ZippedBinder:+    --+    --                   TyBinder           LHsTyVarBndr+    --    ----------------------------------------------+    --    ZippedBinder   forall {k}.+    --    ZippedBinder   forall (a::k).+    --    ZippedBinder   forall (b::k) ->   x+    --    ZippedBinder   (a~b) =>+    --    ZippedBinder   Proxy a ->         p+    --+    -- Given a ZippedBinder zipped_to_tcb produces:+    --+    --  * TyConBinder      for  tyConBinders+    --  * (Name, TcTyVar)  for  tcTyConScopedTyVars, if there's a user-written LHsTyVarBndr+    --+    zipped_to_tcb :: ZippedBinder -> TcM (TyConBinder, [(Name, TcTyVar)])+    zipped_to_tcb zb = case zb of++      -- Inferred variable, no user-written binder.+      -- Example:   forall {k}.+      ZippedBinder (Named (Bndr v Specified)) Nothing ->+        return (mkNamedTyConBinder Specified v, [])++      -- Specified variable, no user-written binder.+      -- Example:   forall (a::k).+      ZippedBinder (Named (Bndr v Inferred)) Nothing ->+        return (mkNamedTyConBinder Inferred v, [])++      -- Constraint, no user-written binder.+      -- Example:   (a~b) =>+      ZippedBinder (Anon InvisArg bndr_ki) Nothing -> do+        name <- newSysName (mkTyVarOccFS (fsLit "ev"))+        let tv = mkTyVar name bndr_ki+        return (mkAnonTyConBinder InvisArg tv, [])++      -- Non-dependent visible argument with a user-written binder.+      -- Example:   Proxy a ->+      ZippedBinder (Anon VisArg bndr_ki) (Just b) ->+        return $+          let v_name = getName b+              tv = mkTyVar v_name bndr_ki+              tcb = mkAnonTyConBinder VisArg tv+          in (tcb, [(v_name, tv)])++      -- Dependent visible argument with a user-written binder.+      -- Example:   forall (b::k) ->+      ZippedBinder (Named (Bndr v Required)) (Just b) ->+        return $+          let v_name = getName b+              tcb = mkNamedTyConBinder Required v+          in (tcb, [(v_name, v)])++      -- 'zipBinders' does not produce any other variants of ZippedBinder.+      _ -> panic "goVis: invalid ZippedBinder"++    -- Given an invisible binder that comes from 'split_invis',+    -- convert it to TyConBinder.+    invis_to_tcb :: TyCoBinder -> TcM TyConBinder+    invis_to_tcb tb = do+      (tcb, stv) <- zipped_to_tcb (ZippedBinder tb Nothing)+      MASSERT(null stv)+      return tcb++    -- similar to:  bindImplicitTKBndrs_Tv+    bind_implicit :: [Name] -> ([(Name,TcTyVar)] -> TcM a) -> TcM a+    bind_implicit tv_names thing_inside =+      do { let new_tv name = do { tcv <- newFlexiKindedTyVarTyVar name+                                ; return (name, tcv) }+         ; tcvs <- mapM new_tv tv_names+         ; tcExtendNameTyVarEnv tcvs (thing_inside tcvs) }++    -- Check that the inline kind annotation on a binder is valid+    -- by unifying it with the kind of the quantifier.+    check_zipped_binder :: ZippedBinder -> TcM ()+    check_zipped_binder (ZippedBinder _ Nothing) = return ()+    check_zipped_binder (ZippedBinder tb (Just b)) =+      case unLoc b of+        UserTyVar _ _ -> return ()+        KindedTyVar _ v v_hs_ki -> do+          v_ki <- tcLHsKindSig (TyVarBndrKindCtxt (unLoc v)) v_hs_ki+          discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig]+            unifyKind (Just (HsTyVar noExtField NotPromoted v))+                      (tyBinderType tb)+                      v_ki+        XTyVarBndr nec -> noExtCon nec++    -- Split the invisible binders that should become a part of 'tyConBinders'+    -- rather than 'tyConResKind'.+    -- See Note [Arity inference in kcCheckDeclHeader_sig]+    split_invis :: Kind -> Maybe Kind -> ([TyCoBinder], Kind)+    split_invis sig_ki Nothing =+      -- instantiate all invisible binders+      splitPiTysInvisible sig_ki+    split_invis sig_ki (Just res_ki) =+      -- subtraction a la checkExpectedKind+      let n_res_invis_bndrs = invisibleTyBndrCount res_ki+          n_sig_invis_bndrs = invisibleTyBndrCount sig_ki+          n_inst = n_sig_invis_bndrs - n_res_invis_bndrs+      in splitPiTysInvisibleN n_inst sig_ki++-- A quantifier from a kind signature zipped with a user-written binder for it.+data ZippedBinder =+  ZippedBinder TyBinder (Maybe (LHsTyVarBndr GhcRn))++-- See Note [Arity inference in kcCheckDeclHeader_sig]+zipBinders+  :: Kind                      -- kind signature+  -> [LHsTyVarBndr GhcRn]      -- user-written binders+  -> ([ZippedBinder],          -- zipped binders+      [LHsTyVarBndr GhcRn],    -- remaining user-written binders+      Kind)                    -- remainder of the kind signature+zipBinders = zip_binders []+  where+    zip_binders acc ki [] = (reverse acc, [], ki)+    zip_binders acc ki (b:bs) =+      case tcSplitPiTy_maybe ki of+        Nothing -> (reverse acc, b:bs, ki)+        Just (tb, ki') ->+          let+            (zb, bs') | zippable  = (ZippedBinder tb (Just b),  bs)+                      | otherwise = (ZippedBinder tb Nothing, b:bs)+            zippable =+              case tb of+                Named (Bndr _ Specified) -> False+                Named (Bndr _ Inferred)  -> False+                Named (Bndr _ Required)  -> True+                Anon InvisArg _ -> False+                Anon VisArg   _ -> True+          in+            zip_binders (zb:acc) ki' bs'++tooManyBindersErr :: Kind -> [LHsTyVarBndr GhcRn] -> SDoc+tooManyBindersErr ki bndrs =+   hang (text "Not a function kind:")+      4 (ppr ki) $$+   hang (text "but extra binders found:")+      4 (fsep (map ppr bndrs))++{- Note [Arity inference in kcCheckDeclHeader_sig]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given a kind signature 'kisig' and a declaration header, kcCheckDeclHeader_sig+verifies that the declaration conforms to the signature. The end result is a+TcTyCon 'tc' such that:++  tyConKind tc == kisig++This TcTyCon would be rather easy to produce if we didn't have to worry about+arity. Consider these declarations:++  type family S1 :: forall k. k -> Type+  type family S2 (a :: k) :: Type++Both S1 and S2 can be given the same standalone kind signature:++  type S2 :: forall k. k -> Type++And, indeed, tyConKind S1 == tyConKind S2. However, tyConKind is built from+tyConBinders and tyConResKind, such that++  tyConKind tc == mkTyConKind (tyConBinders tc) (tyConResKind tc)++For S1 and S2, tyConBinders and tyConResKind are different:++  tyConBinders S1  ==  []+  tyConResKind S1  ==  forall k. k -> Type+  tyConKind    S1  ==  forall k. k -> Type++  tyConBinders S2  ==  [spec k, anon-vis (a :: k)]+  tyConResKind S2  ==  Type+  tyConKind    S1  ==  forall k. k -> Type++This difference determines the arity:++  tyConArity tc == length (tyConBinders tc)++That is, the arity of S1 is 0, while the arity of S2 is 2.++'kcCheckDeclHeader_sig' needs to infer the desired arity to split the standalone+kind signature into binders and the result kind. It does so in two rounds:++1. zip user-written binders (vis_tcbs)+2. split off invisible binders (invis_tcbs)++Consider the following declarations:++    type F :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type+    type family F a b++    type G :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type+    type family G a b :: forall r2. (r1, r2) -> Type++In step 1 (zip user-written binders), we zip the quantifiers in the signature+with the binders in the header using 'zipBinders'. In both F and G, this results in+the following zipped binders:++                   TyBinder     LHsTyVarBndr+    ---------------------------------------+    ZippedBinder   Type ->      a+    ZippedBinder   forall j.+    ZippedBinder   j ->         b+++At this point, we have accumulated three zipped binders which correspond to a+prefix of the standalone kind signature:++  Type -> forall j. j -> ...++In step 2 (split off invisible binders), we have to decide how much remaining+invisible binders of the standalone kind signature to split off:++    forall k1 k2. (k1, k2) -> Type+    ^^^^^^^^^^^^^+    split off or not?++This decision is made in 'split_invis':++* If a user-written result kind signature is not provided, as in F,+  then split off all invisible binders. This is why we need special treatment+  for AnyKind.+* If a user-written result kind signature is provided, as in G,+  then do as checkExpectedKind does and split off (n_sig - n_res) binders.+  That is, split off such an amount of binders that the remainder of the+  standalone kind signature and the user-written result kind signature have the+  same amount of invisible quantifiers.++For F, split_invis splits away all invisible binders, and we have 2:++    forall k1 k2. (k1, k2) -> Type+    ^^^^^^^^^^^^^+    split away both binders++The resulting arity of F is 3+2=5.  (length vis_tcbs = 3,+                                     length invis_tcbs = 2,+                                     length tcbs = 5)++For G, split_invis decides to split off 1 invisible binder, so that we have the+same amount of invisible quantifiers left:++    res_ki  =  forall    r2. (r1, r2) -> Type+    kisig   =  forall k1 k2. (k1, k2) -> Type+                     ^^^+                     split off this one.++The resulting arity of G is 3+1=4. (length vis_tcbs = 3,+                                    length invis_tcbs = 1,+                                    length tcbs = 4)++-}++{- Note [discardResult in kcCheckDeclHeader_sig]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We use 'unifyKind' to check inline kind annotations in declaration headers+against the signature.++  type T :: [i] -> Maybe j -> Type+  data T (a :: [k1]) (b :: Maybe k2) :: Type where ...++Here, we will unify:++       [k1] ~ [i]+  Maybe k2  ~ Maybe j+      Type  ~ Type++The end result is that we fill in unification variables k1, k2:++    k1  :=  i+    k2  :=  j++We also validate that the user isn't confused:++  type T :: Type -> Type+  data T (a :: Bool) = ...++This will report that (Type ~ Bool) failed to unify.++Now, consider the following example:++  type family Id a where Id x = x+  type T :: Bool -> Type+  type T (a :: Id Bool) = ...++We will unify (Bool ~ Id Bool), and this will produce a non-reflexive coercion.+However, we are free to discard it, as the kind of 'T' is determined by the+signature, not by the inline kind annotation:++      we have   T ::    Bool -> Type+  rather than   T :: Id Bool -> Type++This (Id Bool) will not show up anywhere after we're done validating it, so we+have no use for the produced coercion.+-}++{- Note [No polymorphic recursion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Should this kind-check?+  data T ka (a::ka) b  = MkT (T Type           Int   Bool)+                             (T (Type -> Type) Maybe Bool)++Notice that T is used at two different kinds in its RHS.  No!+This should not kind-check.  Polymorphic recursion is known to+be a tough nut.++Previously, we laboriously (with help from the renamer)+tried to give T the polymoprhic kind+   T :: forall ka -> ka -> kappa -> Type+where kappa is a unification variable, even in the inferInitialKinds+phase (which is what kcInferDeclHeader is all about).  But+that is dangerously fragile (see the ticket).++Solution: make kcInferDeclHeader give T a straightforward+monomorphic kind, with no quantification whatsoever. That's why+we use mkAnonTyConBinder for all arguments when figuring out+tc_binders.++But notice that (#16322 comment:3)++* The algorithm successfully kind-checks this declaration:+    data T2 ka (a::ka) = MkT2 (T2 Type a)++  Starting with (inferInitialKinds)+    T2 :: (kappa1 :: kappa2 :: *) -> (kappa3 :: kappa4 :: *) -> *+  we get+    kappa4 := kappa1   -- from the (a:ka) kind signature+    kappa1 := Type     -- From application T2 Type++  These constraints are soluble so generaliseTcTyCon gives+    T2 :: forall (k::Type) -> k -> *++  But now the /typechecking/ (aka desugaring, tcTyClDecl) phase+  fails, because the call (T2 Type a) in the RHS is ill-kinded.++  We'd really prefer all errors to show up in the kind checking+  phase.++* This algorithm still accepts (in all phases)+     data T3 ka (a::ka) = forall b. MkT3 (T3 Type b)+  although T3 is really polymorphic-recursive too.+  Perhaps we should somehow reject that.++Note [Kind-checking tyvar binders for associated types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When kind-checking the type-variable binders for associated+   data/newtype decls+   family decls+we behave specially for type variables that are already in scope;+that is, bound by the enclosing class decl.  This is done in+kcLHsQTyVarBndrs:+  * The use of tcImplicitQTKBndrs+  * The tcLookupLocal_maybe code in kc_hs_tv++See Note [Associated type tyvar names] in Class and+    Note [TyVar binders for associated decls] in GHC.Hs.Decls++We must do the same for family instance decls, where the in-scope+variables may be bound by the enclosing class instance decl.+Hence the use of tcImplicitQTKBndrs in tcFamTyPatsAndGen.++Note [Kind variable ordering for associated types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What should be the kind of `T` in the following example? (#15591)++  class C (a :: Type) where+    type T (x :: f a)++As per Note [Ordering of implicit variables] in RnTypes, we want to quantify+the kind variables in left-to-right order of first occurrence in order to+support visible kind application. But we cannot perform this analysis on just+T alone, since its variable `a` actually occurs /before/ `f` if you consider+the fact that `a` was previously bound by the parent class `C`. That is to say,+the kind of `T` should end up being:++  T :: forall a f. f a -> Type++(It wouldn't necessarily be /wrong/ if the kind ended up being, say,+forall f a. f a -> Type, but that would not be as predictable for users of+visible kind application.)++In contrast, if `T` were redefined to be a top-level type family, like `T2`+below:++  type family T2 (x :: f (a :: Type))++Then `a` first appears /after/ `f`, so the kind of `T2` should be:++  T2 :: forall f a. f a -> Type++In order to make this distinction, we need to know (in kcCheckDeclHeader) which+type variables have been bound by the parent class (if there is one). With+the class-bound variables in hand, we can ensure that we always quantify+these first.+-}+++{- *********************************************************************+*                                                                      *+             Expected kinds+*                                                                      *+********************************************************************* -}++-- | Describes the kind expected in a certain context.+data ContextKind = TheKind Kind   -- ^ a specific kind+                 | AnyKind        -- ^ any kind will do+                 | OpenKind       -- ^ something of the form @TYPE _@++-----------------------+newExpectedKind :: ContextKind -> TcM Kind+newExpectedKind (TheKind k) = return k+newExpectedKind AnyKind     = newMetaKindVar+newExpectedKind OpenKind    = newOpenTypeKind++-----------------------+expectedKindInCtxt :: UserTypeCtxt -> ContextKind+-- Depending on the context, we might accept any kind (for instance, in a TH+-- splice), or only certain kinds (like in type signatures).+expectedKindInCtxt (TySynCtxt _)   = AnyKind+expectedKindInCtxt ThBrackCtxt     = AnyKind+expectedKindInCtxt (GhciCtxt {})   = AnyKind+-- The types in a 'default' decl can have varying kinds+-- See Note [Extended defaults]" in TcEnv+expectedKindInCtxt DefaultDeclCtxt     = AnyKind+expectedKindInCtxt TypeAppCtxt         = AnyKind+expectedKindInCtxt (ForSigCtxt _)      = TheKind liftedTypeKind+expectedKindInCtxt (InstDeclCtxt {})   = TheKind constraintKind+expectedKindInCtxt SpecInstCtxt        = TheKind constraintKind+expectedKindInCtxt _                   = OpenKind+++{- *********************************************************************+*                                                                      *+             Bringing type variables into scope+*                                                                      *+********************************************************************* -}++--------------------------------------+-- Implicit binders+--------------------------------------++bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv,+  bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv+  :: [Name] -> TcM a -> TcM ([TcTyVar], a)+bindImplicitTKBndrs_Skol   = bindImplicitTKBndrsX newFlexiKindedSkolemTyVar+bindImplicitTKBndrs_Tv     = bindImplicitTKBndrsX newFlexiKindedTyVarTyVar+bindImplicitTKBndrs_Q_Skol = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedSkolemTyVar)+bindImplicitTKBndrs_Q_Tv   = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedTyVarTyVar)++bindImplicitTKBndrsX+   :: (Name -> TcM TcTyVar) -- new_tv function+   -> [Name]+   -> TcM a+   -> TcM ([TcTyVar], a)   -- Returned [TcTyVar] are in 1-1 correspondence+                           -- with the passed in [Name]+bindImplicitTKBndrsX new_tv tv_names thing_inside+  = do { tkvs <- mapM new_tv tv_names+       ; traceTc "bindImplicitTKBndrs" (ppr tv_names $$ ppr tkvs)+       ; res <- tcExtendNameTyVarEnv (tv_names `zip` tkvs)+                thing_inside+       ; return (tkvs, res) }++newImplicitTyVarQ :: (Name -> TcM TcTyVar) ->  Name -> TcM TcTyVar+-- Behave like new_tv, except that if the tyvar is in scope, use it+newImplicitTyVarQ new_tv name+  = do { mb_tv <- tcLookupLcl_maybe name+       ; case mb_tv of+           Just (ATyVar _ tv) -> return tv+           _ -> new_tv name }++newFlexiKindedTyVar :: (Name -> Kind -> TcM TyVar) -> Name -> TcM TyVar+newFlexiKindedTyVar new_tv name+  = do { kind <- newMetaKindVar+       ; new_tv name kind }++newFlexiKindedSkolemTyVar :: Name -> TcM TyVar+newFlexiKindedSkolemTyVar = newFlexiKindedTyVar newSkolemTyVar++newFlexiKindedTyVarTyVar :: Name -> TcM TyVar+newFlexiKindedTyVarTyVar = newFlexiKindedTyVar newTyVarTyVar+   -- See Note [Unification variables need fresh Names] in TcMType++--------------------------------------+-- Explicit binders+--------------------------------------++bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv+    :: [LHsTyVarBndr GhcRn]+    -> TcM a+    -> TcM ([TcTyVar], a)++bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (tcHsTyVarBndr newSkolemTyVar)+bindExplicitTKBndrs_Tv   = bindExplicitTKBndrsX (tcHsTyVarBndr newTyVarTyVar)++bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv+    :: ContextKind+    -> [LHsTyVarBndr GhcRn]+    -> TcM a+    -> TcM ([TcTyVar], a)++bindExplicitTKBndrs_Q_Skol ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newSkolemTyVar)+bindExplicitTKBndrs_Q_Tv   ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newTyVarTyVar)++bindExplicitTKBndrsX+    :: (HsTyVarBndr GhcRn -> TcM TcTyVar)+    -> [LHsTyVarBndr GhcRn]+    -> TcM a+    -> TcM ([TcTyVar], a)  -- Returned [TcTyVar] are in 1-1 correspondence+                           -- with the passed-in [LHsTyVarBndr]+bindExplicitTKBndrsX tc_tv hs_tvs thing_inside+  = do { traceTc "bindExplicTKBndrs" (ppr hs_tvs)+       ; go hs_tvs }+  where+    go [] = do { res <- thing_inside+               ; return ([], res) }+    go (L _ hs_tv : hs_tvs)+       = do { tv <- tc_tv hs_tv+            -- Extend the environment as we go, in case a binder+            -- is mentioned in the kind of a later binder+            --   e.g. forall k (a::k). blah+            -- NB: tv's Name may differ from hs_tv's+            -- See TcMType Note [Unification variables need fresh Names]+            ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $+                           go hs_tvs+            ; return (tv:tvs, res) }++-----------------+tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar)+              -> HsTyVarBndr GhcRn -> TcM TcTyVar+-- Returned TcTyVar has the same name; no cloning+tcHsTyVarBndr new_tv (UserTyVar _ (L _ tv_nm))+  = do { kind <- newMetaKindVar+       ; new_tv tv_nm kind }+tcHsTyVarBndr new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind)+  = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind+       ; new_tv tv_nm kind }+tcHsTyVarBndr _ (XTyVarBndr nec) = noExtCon nec++-----------------+tcHsQTyVarBndr :: ContextKind+               -> (Name -> Kind -> TcM TyVar)+               -> HsTyVarBndr GhcRn -> TcM TcTyVar+-- Just like tcHsTyVarBndr, but also+--   - uses the in-scope TyVar from class, if it exists+--   - takes a ContextKind to use for the no-sig case+tcHsQTyVarBndr ctxt_kind new_tv (UserTyVar _ (L _ tv_nm))+  = do { mb_tv <- tcLookupLcl_maybe tv_nm+       ; case mb_tv of+           Just (ATyVar _ tv) -> return tv+           _ -> do { kind <- newExpectedKind ctxt_kind+                   ; new_tv tv_nm kind } }++tcHsQTyVarBndr _ new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind)+  = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind+       ; mb_tv <- tcLookupLcl_maybe tv_nm+       ; case mb_tv of+           Just (ATyVar _ tv)+             -> do { discardResult $ unifyKind (Just hs_tv)+                                        kind (tyVarKind tv)+                       -- This unify rejects:+                       --    class C (m :: * -> *) where+                       --      type F (m :: *) = ...+                   ; return tv }++           _ -> new_tv tv_nm kind }+  where+    hs_tv = HsTyVar noExtField NotPromoted (noLoc tv_nm)+            -- Used for error messages only++tcHsQTyVarBndr _ _ (XTyVarBndr nec) = noExtCon nec++--------------------------------------+-- Binding type/class variables in the+-- kind-checking and typechecking phases+--------------------------------------++bindTyClTyVars :: Name+               -> ([TyConBinder] -> Kind -> TcM a) -> TcM a+-- ^ Used for the type variables of a type or class decl+-- in the "kind checking" and "type checking" pass,+-- but not in the initial-kind run.+bindTyClTyVars tycon_name thing_inside+  = do { tycon <- kcLookupTcTyCon tycon_name+       ; let scoped_prs = tcTyConScopedTyVars tycon+             res_kind   = tyConResKind tycon+             binders    = tyConBinders tycon+       ; traceTc "bindTyClTyVars" (ppr tycon_name <+> ppr binders $$ ppr scoped_prs)+       ; tcExtendNameTyVarEnv scoped_prs $+         thing_inside binders res_kind }++-- inferInitialKind has made a suitably-shaped kind for the type or class+-- Look it up in the local environment. This is used only for tycons+-- that we're currently type-checking, so we're sure to find a TcTyCon.+kcLookupTcTyCon :: Name -> TcM TcTyCon+kcLookupTcTyCon nm+  = do { tc_ty_thing <- tcLookup nm+       ; return $ case tc_ty_thing of+           ATcTyCon tc -> tc+           _           -> pprPanic "kcLookupTcTyCon" (ppr tc_ty_thing) }+++{- *********************************************************************+*                                                                      *+             Kind generalisation+*                                                                      *+********************************************************************* -}++zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar]+zonkAndScopedSort spec_tkvs+  = do { spec_tkvs <- mapM zonkAndSkolemise spec_tkvs+          -- Use zonkAndSkolemise because a skol_tv might be a TyVarTv++       -- Do a stable topological sort, following+       -- Note [Ordering of implicit variables] in RnTypes+       ; return (scopedSort spec_tkvs) }++-- | Generalize some of the free variables in the given type.+-- All such variables should be *kind* variables; any type variables+-- should be explicitly quantified (with a `forall`) before now.+-- The supplied predicate says which free variables to quantify.+-- But in all cases,+-- generalize only those variables whose TcLevel is strictly greater+-- than the ambient level. This "strictly greater than" means that+-- you likely need to push the level before creating whatever type+-- gets passed here. Any variable whose level is greater than the+-- ambient level but is not selected to be generalized will be+-- promoted. (See [Promoting unification variables] in TcSimplify+-- and Note [Recipe for checking a signature].)+-- The resulting KindVar are the variables to+-- quantify over, in the correct, well-scoped order. They should+-- generally be Inferred, not Specified, but that's really up to+-- the caller of this function.+kindGeneralizeSome :: (TcTyVar -> Bool)+                   -> TcType    -- ^ needn't be zonked+                   -> TcM [KindVar]+kindGeneralizeSome should_gen kind_or_type+  = do { traceTc "kindGeneralizeSome {" (ppr kind_or_type)++         -- use the "Kind" variant here, as any types we see+         -- here will already have all type variables quantified;+         -- thus, every free variable is really a kv, never a tv.+       ; dvs <- candidateQTyVarsOfKind kind_or_type++       -- So 'dvs' are the variables free in kind_or_type, with a level greater+       -- than the ambient level, hence candidates for quantification+       -- Next: filter out the ones we don't want to generalize (specified by should_gen)+       -- and promote them instead++       ; let (to_promote, dvs') = partitionCandidates dvs (not . should_gen)++       ; (_, promoted) <- promoteTyVarSet (dVarSetToVarSet to_promote)+       ; qkvs <- quantifyTyVars dvs'++       ; traceTc "kindGeneralizeSome }" $+         vcat [ text "Kind or type:" <+> ppr kind_or_type+              , text "dvs:" <+> ppr dvs+              , text "dvs':" <+> ppr dvs'+              , text "to_promote:" <+> pprTyVars (dVarSetElems to_promote)+              , text "promoted:" <+> pprTyVars (nonDetEltsUniqSet promoted)+              , text "qkvs:" <+> pprTyVars qkvs ]++       ; return qkvs }++-- | Specialized version of 'kindGeneralizeSome', but where all variables+-- can be generalized. Use this variant when you can be sure that no more+-- constraints on the type's metavariables will arise or be solved.+kindGeneralizeAll :: TcType  -- needn't be zonked+                  -> TcM [KindVar]+kindGeneralizeAll ty = do { traceTc "kindGeneralizeAll" empty+                          ; kindGeneralizeSome (const True) ty }++-- | Specialized version of 'kindGeneralizeSome', but where no variables+-- can be generalized. Use this variant when it is unknowable whether metavariables+-- might later be constrained.+-- See Note [Recipe for checking a signature] for why and where this+-- function is needed.+kindGeneralizeNone :: TcType  -- needn't be zonked+                   -> TcM ()+kindGeneralizeNone ty+  = do { traceTc "kindGeneralizeNone" empty+       ; kvs <- kindGeneralizeSome (const False) ty+       ; MASSERT( null kvs )+       }++{- Note [Levels and generalisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f x = e+with no type signature. We are currently at level i.+We must+  * Push the level to level (i+1)+  * Allocate a fresh alpha[i+1] for the result type+  * Check that e :: alpha[i+1], gathering constraint WC+  * Solve WC as far as possible+  * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i]+  * Find the free variables with level > i, in this case gamma[i]+  * Skolemise those free variables and quantify over them, giving+       f :: forall g. beta[i-1] -> g+  * Emit the residiual constraint wrapped in an implication for g,+    thus   forall g. WC++All of this happens for types too.  Consider+  f :: Int -> (forall a. Proxy a -> Int)++Note [Kind generalisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We do kind generalisation only at the outer level of a type signature.+For example, consider+  T :: forall k. k -> *+  f :: (forall a. T a -> Int) -> Int+When kind-checking f's type signature we generalise the kind at+the outermost level, thus:+  f1 :: forall k. (forall (a:k). T k a -> Int) -> Int  -- YES!+and *not* at the inner forall:+  f2 :: (forall k. forall (a:k). T k a -> Int) -> Int  -- NO!+Reason: same as for HM inference on value level declarations,+we want to infer the most general type.  The f2 type signature+would be *less applicable* than f1, because it requires a more+polymorphic argument.++NB: There are no explicit kind variables written in f's signature.+When there are, the renamer adds these kind variables to the list of+variables bound by the forall, so you can indeed have a type that's+higher-rank in its kind. But only by explicit request.++Note [Kinds of quantified type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcTyVarBndrsGen quantifies over a specified list of type variables,+*and* over the kind variables mentioned in the kinds of those tyvars.++Note that we must zonk those kinds (obviously) but less obviously, we+must return type variables whose kinds are zonked too. Example+    (a :: k7)  where  k7 := k9 -> k9+We must return+    [k9, a:k9->k9]+and NOT+    [k9, a:k7]+Reason: we're going to turn this into a for-all type,+   forall k9. forall (a:k7). blah+which the type checker will then instantiate, and instantiate does not+look through unification variables!++Hence using zonked_kinds when forming tvs'.++-}++-----------------------------------+etaExpandAlgTyCon :: [TyConBinder]+                  -> Kind+                  -> TcM ([TyConBinder], Kind)+-- GADT decls can have a (perhaps partial) kind signature+--      e.g.  data T a :: * -> * -> * where ...+-- This function makes up suitable (kinded) TyConBinders for the+-- argument kinds.  E.g. in this case it might return+--   ([b::*, c::*], *)+-- Never emits constraints.+-- It's a little trickier than you might think: see+-- Note [TyConBinders for the result kind signature of a data type]+etaExpandAlgTyCon tc_bndrs kind+  = do  { loc     <- getSrcSpanM+        ; uniqs   <- newUniqueSupply+        ; rdr_env <- getLocalRdrEnv+        ; let new_occs = [ occ+                         | str <- allNameStrings+                         , let occ = mkOccName tvName str+                         , isNothing (lookupLocalRdrOcc rdr_env occ)+                         -- Note [Avoid name clashes for associated data types]+                         , not (occ `elem` lhs_occs) ]+              new_uniqs = uniqsFromSupply uniqs+              subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet lhs_tvs))+        ; return (go loc new_occs new_uniqs subst [] kind) }+  where+    lhs_tvs  = map binderVar tc_bndrs+    lhs_occs = map getOccName lhs_tvs++    go loc occs uniqs subst acc kind+      = case splitPiTy_maybe kind of+          Nothing -> (reverse acc, substTy subst kind)++          Just (Anon af arg, kind')+            -> go loc occs' uniqs' subst' (tcb : acc) kind'+            where+              arg'   = substTy subst arg+              tv     = mkTyVar (mkInternalName uniq occ loc) arg'+              subst' = extendTCvInScope subst tv+              tcb    = Bndr tv (AnonTCB af)+              (uniq:uniqs') = uniqs+              (occ:occs')   = occs++          Just (Named (Bndr tv vis), kind')+            -> go loc occs uniqs subst' (tcb : acc) kind'+            where+              (subst', tv') = substTyVarBndr subst tv+              tcb = Bndr tv' (NamedTCB vis)++-- | A description of whether something is a+--+-- * @data@ or @newtype@ ('DataDeclSort')+--+-- * @data instance@ or @newtype instance@ ('DataInstanceSort')+--+-- * @data family@ ('DataFamilySort')+--+-- At present, this data type is only consumed by 'checkDataKindSig'.+data DataSort+  = DataDeclSort     NewOrData+  | DataInstanceSort NewOrData+  | DataFamilySort++-- | Checks that the return kind in a data declaration's kind signature is+-- permissible. There are three cases:+--+-- If dealing with a @data@, @newtype@, @data instance@, or @newtype instance@+-- declaration, check that the return kind is @Type@.+--+-- If the declaration is a @newtype@ or @newtype instance@ and the+-- @UnliftedNewtypes@ extension is enabled, this check is slightly relaxed so+-- that a return kind of the form @TYPE r@ (for some @r@) is permitted.+-- See @Note [Implementation of UnliftedNewtypes]@ in "TcTyClsDecls".+--+-- If dealing with a @data family@ declaration, check that the return kind is+-- either of the form:+--+-- 1. @TYPE r@ (for some @r@), or+--+-- 2. @k@ (where @k@ is a bare kind variable; see #12369)+checkDataKindSig :: DataSort -> Kind -> TcM ()+checkDataKindSig data_sort kind = do+  dflags <- getDynFlags+  checkTc (is_TYPE_or_Type dflags || is_kind_var) (err_msg dflags)+  where+    pp_dec :: SDoc+    pp_dec = text $+      case data_sort of+        DataDeclSort     DataType -> "data type"+        DataDeclSort     NewType  -> "newtype"+        DataInstanceSort DataType -> "data instance"+        DataInstanceSort NewType  -> "newtype instance"+        DataFamilySort            -> "data family"++    is_newtype :: Bool+    is_newtype =+      case data_sort of+        DataDeclSort     new_or_data -> new_or_data == NewType+        DataInstanceSort new_or_data -> new_or_data == NewType+        DataFamilySort               -> False++    is_data_family :: Bool+    is_data_family =+      case data_sort of+        DataDeclSort{}     -> False+        DataInstanceSort{} -> False+        DataFamilySort     -> True++    tYPE_ok :: DynFlags -> Bool+    tYPE_ok dflags =+         (is_newtype && xopt LangExt.UnliftedNewtypes dflags)+           -- With UnliftedNewtypes, we allow kinds other than Type, but they+           -- must still be of the form `TYPE r` since we don't want to accept+           -- Constraint or Nat.+           -- See Note [Implementation of UnliftedNewtypes] in TcTyClsDecls.+      || is_data_family+           -- If this is a `data family` declaration, we don't need to check if+           -- UnliftedNewtypes is enabled, since data family declarations can+           -- have return kind `TYPE r` unconditionally (#16827).++    is_TYPE :: Bool+    is_TYPE = tcIsRuntimeTypeKind kind++    is_TYPE_or_Type :: DynFlags -> Bool+    is_TYPE_or_Type dflags | tYPE_ok dflags = is_TYPE+                           | otherwise      = tcIsLiftedTypeKind kind++    -- In the particular case of a data family, permit a return kind of the+    -- form `:: k` (where `k` is a bare kind variable).+    is_kind_var :: Bool+    is_kind_var | is_data_family = isJust (tcGetCastedTyVar_maybe kind)+                | otherwise      = False++    err_msg :: DynFlags -> SDoc+    err_msg dflags =+      sep [ (sep [ text "Kind signature on" <+> pp_dec <+>+                   text "declaration has non-" <>+                   (if tYPE_ok dflags then text "TYPE" else ppr liftedTypeKind)+                 , (if is_data_family then text "and non-variable" else empty) <+>+                   text "return kind" <+> quotes (ppr kind) ])+          , if not (tYPE_ok dflags) && is_TYPE && is_newtype &&+               not (xopt LangExt.UnliftedNewtypes dflags)+            then text "Perhaps you intended to use UnliftedNewtypes"+            else empty ]++-- | Checks that the result kind of a class is exactly `Constraint`, rejecting+-- type synonyms and type families that reduce to `Constraint`. See #16826.+checkClassKindSig :: Kind -> TcM ()+checkClassKindSig kind = checkTc (tcIsConstraintKind kind) err_msg+  where+    err_msg :: SDoc+    err_msg =+      text "Kind signature on a class must end with" <+> ppr constraintKind $$+      text "unobscured by type families"++tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis]+-- Result is in 1-1 correpondence with orig_args+tcbVisibilities tc orig_args+  = go (tyConKind tc) init_subst orig_args+  where+    init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes orig_args))+    go _ _ []+      = []++    go fun_kind subst all_args@(arg : args)+      | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind+      = case tcb of+          Anon af _           -> AnonTCB af   : go inner_kind subst  args+          Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args+                 where+                    subst' = extendTCvSubst subst tv arg++      | not (isEmptyTCvSubst subst)+      = go (substTy subst fun_kind) init_subst all_args++      | otherwise+      = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args)+++{- Note [TyConBinders for the result kind signature of a data type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given+  data T (a::*) :: * -> forall k. k -> *+we want to generate the extra TyConBinders for T, so we finally get+  (a::*) (b::*) (k::*) (c::k)+The function etaExpandAlgTyCon generates these extra TyConBinders from+the result kind signature.++We need to take care to give the TyConBinders+  (a) OccNames that are fresh (because the TyConBinders of a TyCon+      must have distinct OccNames++  (b) Uniques that are fresh (obviously)++For (a) we need to avoid clashes with the tyvars declared by+the user before the "::"; in the above example that is 'a'.+And also see Note [Avoid name clashes for associated data types].++For (b) suppose we have+   data T :: forall k. k -> forall k. k -> *+where the two k's are identical even up to their uniques.  Surprisingly,+this can happen: see #14515.++It's reasonably easy to solve all this; just run down the list with a+substitution; hence the recursive 'go' function.  But it has to be+done.++Note [Avoid name clashes for associated data types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider    class C a b where+               data D b :: * -> *+When typechecking the decl for D, we'll invent an extra type variable+for D, to fill out its kind.  Ideally we don't want this type variable+to be 'a', because when pretty printing we'll get+            class C a b where+               data D b a0+(NB: the tidying happens in the conversion to IfaceSyn, which happens+as part of pretty-printing a TyThing.)++That's why we look in the LocalRdrEnv to see what's in scope. This is+important only to get nice-looking output when doing ":info C" in GHCi.+It isn't essential for correctness.+++************************************************************************+*                                                                      *+             Partial signatures+*                                                                      *+************************************************************************++-}++tcHsPartialSigType+  :: UserTypeCtxt+  -> LHsSigWcType GhcRn       -- The type signature+  -> TcM ( [(Name, TcTyVar)]  -- Wildcards+         , Maybe TcType       -- Extra-constraints wildcard+         , [(Name,TcTyVar)]   -- Original tyvar names, in correspondence with+                              --   the implicitly and explicitly bound type variables+         , TcThetaType        -- Theta part+         , TcType )           -- Tau part+-- See Note [Checking partial type signatures]+tcHsPartialSigType ctxt sig_ty+  | HsWC { hswc_ext  = sig_wcs, hswc_body = ib_ty } <- sig_ty+  , HsIB { hsib_ext = implicit_hs_tvs+         , hsib_body = hs_ty } <- ib_ty+  , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTyInvis hs_ty+  = addSigCtxt ctxt hs_ty $+    do { (implicit_tvs, (explicit_tvs, (wcs, wcx, theta, tau)))+            <- solveLocalEqualities "tcHsPartialSigType"    $+                 -- This solveLocalEqualiltes fails fast if there are+                 -- insoluble equalities. See TcSimplify+                 -- Note [Fail fast if there are insoluble kind equalities]+               tcNamedWildCardBinders sig_wcs $ \ wcs ->+               bindImplicitTKBndrs_Tv implicit_hs_tvs       $+               bindExplicitTKBndrs_Tv explicit_hs_tvs       $+               do {   -- Instantiate the type-class context; but if there+                      -- is an extra-constraints wildcard, just discard it here+                    (theta, wcx) <- tcPartialContext hs_ctxt++                  ; tau <- tcHsOpenType hs_tau++                  ; return (wcs, wcx, theta, tau) }++         -- No kind-generalization here:+       ; kindGeneralizeNone (mkSpecForAllTys implicit_tvs $+                             mkSpecForAllTys explicit_tvs $+                             mkPhiTy theta $+                             tau)++       -- Spit out the wildcards (including the extra-constraints one)+       -- as "hole" constraints, so that they'll be reported if necessary+       -- See Note [Extra-constraint holes in partial type signatures]+       ; emitNamedWildCardHoleConstraints wcs++         -- We return a proper (Name,TyVar) environment, to be sure that+         -- we bring the right name into scope in the function body.+         -- Test case: partial-sigs/should_compile/LocalDefinitionBug+       ; let tv_prs = (implicit_hs_tvs                  `zip` implicit_tvs)+                      ++ (hsLTyVarNames explicit_hs_tvs `zip` explicit_tvs)++      -- NB: checkValidType on the final inferred type will be+      --     done later by checkInferredPolyId.  We can't do it+      --     here because we don't have a complete tuype to check++       ; traceTc "tcHsPartialSigType" (ppr tv_prs)+       ; return (wcs, wcx, tv_prs, theta, tau) }++tcHsPartialSigType _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec+tcHsPartialSigType _ (XHsWildCardBndrs nec) = noExtCon nec++tcPartialContext :: HsContext GhcRn -> TcM (TcThetaType, Maybe TcType)+tcPartialContext hs_theta+  | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta+  , L wc_loc wc@(HsWildCardTy _) <- ignoreParens hs_ctxt_last+  = do { wc_tv_ty <- setSrcSpan wc_loc $+                     tcAnonWildCardOcc wc constraintKind+       ; theta <- mapM tcLHsPredType hs_theta1+       ; return (theta, Just wc_tv_ty) }+  | otherwise+  = do { theta <- mapM tcLHsPredType hs_theta+       ; return (theta, Nothing) }++{- Note [Checking partial type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [Recipe for checking a signature]++When we have a parital signature like+   f,g :: forall a. a -> _+we do the following++* In TcSigs.tcUserSigType we return a PartialSig, which (unlike+  the companion CompleteSig) contains the original, as-yet-unchecked+  source-code LHsSigWcType++* Then, for f and g /separately/, we call tcInstSig, which in turn+  call tchsPartialSig (defined near this Note).  It kind-checks the+  LHsSigWcType, creating fresh unification variables for each "_"+  wildcard.  It's important that the wildcards for f and g are distinct+  becase they migh get instantiated completely differently.  E.g.+     f,g :: forall a. a -> _+     f x = a+     g x = True+  It's really as if we'd written two distinct signatures.++* Note that we don't make quantified type (forall a. blah) and then+  instantiate it -- it makes no sense to instantiate a type with+  wildcards in it.  Rather, tcHsPartialSigType just returns the+  'a' and the 'blah' separately.++  Nor, for the same reason, do we push a level in tcHsPartialSigType.++Note [Extra-constraint holes in partial type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f :: (_) => a -> a+  f x = ...++* The renamer leaves '_' untouched.++* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in+  tcWildCardBinders.++* TcBinds.chooseInferredQuantifiers fills in that hole TcTyVar+  with the inferred constraints, e.g. (Eq a, Show a)++* TcErrors.mkHoleError finally reports the error.++An annoying difficulty happens if there are more than 62 inferred+constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple.+Where do we find the TyCon?  For good reasons we only have constraint+tuples up to 62 (see Note [How tuples work] in TysWiredIn).  So how+can we make a 70-tuple?  This was the root cause of #14217.++It's incredibly tiresome, because we only need this type to fill+in the hole, to communicate to the error reporting machinery.  Nothing+more.  So I use a HACK:++* I make an /ordinary/ tuple of the constraints, in+  TcBinds.chooseInferredQuantifiers. This is ill-kinded because+  ordinary tuples can't contain constraints, but it works fine. And for+  ordinary tuples we don't have the same limit as for constraint+  tuples (which need selectors and an assocated class).++* Because it is ill-kinded, it trips an assert in writeMetaTyVar,+  so now I disable the assertion if we are writing a type of+  kind Constraint.  (That seldom/never normally happens so we aren't+  losing much.)++Result works fine, but it may eventually bite us.+++************************************************************************+*                                                                      *+      Pattern signatures (i.e signatures that occur in patterns)+*                                                                      *+********************************************************************* -}++tcHsPatSigType :: UserTypeCtxt+               -> LHsSigWcType GhcRn          -- The type signature+               -> TcM ( [(Name, TcTyVar)]     -- Wildcards+                      , [(Name, TcTyVar)]     -- The new bit of type environment, binding+                                              -- the scoped type variables+                      , TcType)       -- The type+-- Used for type-checking type signatures in+-- (a) patterns           e.g  f (x::Int) = e+-- (b) RULE forall bndrs  e.g. forall (x::Int). f x = x+--+-- This may emit constraints+-- See Note [Recipe for checking a signature]+tcHsPatSigType ctxt sig_ty+  | HsWC { hswc_ext = sig_wcs,   hswc_body = ib_ty } <- sig_ty+  , HsIB { hsib_ext = sig_ns+         , hsib_body = hs_ty } <- ib_ty+  = addSigCtxt ctxt hs_ty $+    do { sig_tkv_prs <- mapM new_implicit_tv sig_ns+       ; (wcs, sig_ty)+            <- solveLocalEqualities "tcHsPatSigType" $+                 -- Always solve local equalities if possible,+                 -- else casts get in the way of deep skolemisation+                 -- (#16033)+               tcNamedWildCardBinders sig_wcs        $ \ wcs ->+               tcExtendNameTyVarEnv sig_tkv_prs $+               do { sig_ty <- tcHsOpenType hs_ty+                  ; return (wcs, sig_ty) }++        ; emitNamedWildCardHoleConstraints wcs++          -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty+          -- contains a forall). Promote these.+          -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ...+          -- When we instantiate x, we have to compare the kind of the argument+          -- to a's kind, which will be a metavariable.+          -- kindGeneralizeNone does this:+        ; kindGeneralizeNone sig_ty+        ; sig_ty <- zonkTcType sig_ty+        ; checkValidType ctxt sig_ty++        ; traceTc "tcHsPatSigType" (ppr sig_tkv_prs)+        ; return (wcs, sig_tkv_prs, sig_ty) }+  where+    new_implicit_tv name+      = do { kind <- newMetaKindVar+           ; tv   <- case ctxt of+                       RuleSigCtxt {} -> newSkolemTyVar name kind+                       _              -> newPatSigTyVar name kind+                       -- See Note [Pattern signature binders]+             -- NB: tv's Name may be fresh (in the case of newPatSigTyVar)+           ; return (name, tv) }++tcHsPatSigType _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec+tcHsPatSigType _ (XHsWildCardBndrs nec)          = noExtCon nec++tcPatSig :: Bool                    -- True <=> pattern binding+         -> LHsSigWcType GhcRn+         -> ExpSigmaType+         -> TcM (TcType,            -- The type to use for "inside" the signature+                 [(Name,TcTyVar)],  -- The new bit of type environment, binding+                                    -- the scoped type variables+                 [(Name,TcTyVar)],  -- The wildcards+                 HsWrapper)         -- Coercion due to unification with actual ty+                                    -- Of shape:  res_ty ~ sig_ty+tcPatSig in_pat_bind sig res_ty+ = do  { (sig_wcs, sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt sig+        -- sig_tvs are the type variables free in 'sig',+        -- and not already in scope. These are the ones+        -- that should be brought into scope++        ; if null sig_tvs then do {+                -- Just do the subsumption check and return+                  wrap <- addErrCtxtM (mk_msg sig_ty) $+                          tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty+                ; return (sig_ty, [], sig_wcs, wrap)+        } else do+                -- Type signature binds at least one scoped type variable++                -- A pattern binding cannot bind scoped type variables+                -- It is more convenient to make the test here+                -- than in the renamer+        { when in_pat_bind (addErr (patBindSigErr sig_tvs))++        -- Now do a subsumption check of the pattern signature against res_ty+        ; wrap <- addErrCtxtM (mk_msg sig_ty) $+                  tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty++        -- Phew!+        ; return (sig_ty, sig_tvs, sig_wcs, wrap)+        } }+  where+    mk_msg sig_ty tidy_env+       = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty+            ; res_ty <- readExpType res_ty   -- should be filled in by now+            ; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty+            ; let msg = vcat [ hang (text "When checking that the pattern signature:")+                                  4 (ppr sig_ty)+                             , nest 2 (hang (text "fits the type of its context:")+                                          2 (ppr res_ty)) ]+            ; return (tidy_env, msg) }++patBindSigErr :: [(Name,TcTyVar)] -> SDoc+patBindSigErr sig_tvs+  = hang (text "You cannot bind scoped type variable" <> plural sig_tvs+          <+> pprQuotedList (map fst sig_tvs))+       2 (text "in a pattern binding signature")++{- Note [Pattern signature binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [Type variables in the type environment] in TcRnTypes.+Consider++  data T where+    MkT :: forall a. a -> (a -> Int) -> T++  f :: T -> ...+  f (MkT x (f :: b -> c)) = <blah>++Here+ * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk',+   It must be a skolem so that that it retains its identity, and+   TcErrors.getSkolemInfo can thereby find the binding site for the skolem.++ * The type signature pattern (f :: b -> c) makes freshs meta-tyvars+   beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the+   environment++ * Then unification makes beta := a_sk, gamma := Int+   That's why we must make beta and gamma a MetaTv,+   not a SkolemTv, so that it can unify to a_sk (or Int, respectively).++ * Finally, in '<blah>' we have the envt "b" :-> beta, "c" :-> gamma,+   so we return the pairs ("b" :-> beta, "c" :-> gamma) from tcHsPatSigType,++Another example (#13881):+   fl :: forall (l :: [a]). Sing l -> Sing l+   fl (SNil :: Sing (l :: [y])) = SNil+When we reach the pattern signature, 'l' is in scope from the+outer 'forall':+   "a" :-> a_sk :: *+   "l" :-> l_sk :: [a_sk]+We make up a fresh meta-TauTv, y_sig, for 'y', and kind-check+the pattern signature+   Sing (l :: [y])+That unifies y_sig := a_sk.  We return from tcHsPatSigType with+the pair ("y" :-> y_sig).++For RULE binders, though, things are a bit different (yuk).+  RULE "foo" forall (x::a) (y::[a]).  f x y = ...+Here this really is the binding site of the type variable so we'd like+to use a skolem, so that we get a complaint if we unify two of them+together.  Hence the new_tv function in tcHsPatSigType.+++************************************************************************+*                                                                      *+        Checking kinds+*                                                                      *+************************************************************************++-}++unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind)+unifyKinds rn_tys act_kinds+  = do { kind <- newMetaKindVar+       ; let check rn_ty (ty, act_kind)+               = checkExpectedKind (unLoc rn_ty) ty act_kind kind+       ; tys' <- zipWithM check rn_tys act_kinds+       ; return (tys', kind) }++{-+************************************************************************+*                                                                      *+        Sort checking kinds+*                                                                      *+************************************************************************++tcLHsKindSig converts a user-written kind to an internal, sort-checked kind.+It does sort checking and desugaring at the same time, in one single pass.+-}++tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind+tcLHsKindSig ctxt hs_kind+-- See  Note [Recipe for checking a signature] in TcHsType+-- Result is zonked+  = do { kind <- solveLocalEqualities "tcLHsKindSig" $+                 tc_lhs_kind kindLevelMode hs_kind+       ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind)+       -- No generalization:+       ; kindGeneralizeNone kind+       ; kind <- zonkTcType kind+         -- This zonk is very important in the case of higher rank kinds+         -- E.g. #13879    f :: forall (p :: forall z (y::z). <blah>).+         --                          <more blah>+         --      When instantiating p's kind at occurrences of p in <more blah>+         --      it's crucial that the kind we instantiate is fully zonked,+         --      else we may fail to substitute properly++       ; checkValidType ctxt kind+       ; traceTc "tcLHsKindSig2" (ppr kind)+       ; return kind }++tc_lhs_kind :: TcTyMode -> LHsKind GhcRn -> TcM Kind+tc_lhs_kind mode k+  = addErrCtxt (text "In the kind" <+> quotes (ppr k)) $+    tc_lhs_type (kindLevel mode) k liftedTypeKind++promotionErr :: Name -> PromotionErr -> TcM a+promotionErr name err+  = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here")+                   2 (parens reason))+  where+    reason = case err of+               ConstrainedDataConPE pred+                              -> text "it has an unpromotable context"+                                 <+> quotes (ppr pred)+               FamDataConPE   -> text "it comes from a data family instance"+               NoDataKindsTC  -> text "perhaps you intended to use DataKinds"+               NoDataKindsDC  -> text "perhaps you intended to use DataKinds"+               PatSynPE       -> text "pattern synonyms cannot be promoted"+               _ -> text "it is defined and used in the same recursive group"++{-+************************************************************************+*                                                                      *+          Error messages and such+*                                                                      *+************************************************************************+-}+  -- | If the inner action emits constraints, report them as errors and fail; -- otherwise, propagates the return value. Useful as a wrapper around
compiler/typecheck/TcInstDcls.hs view
@@ -12,11 +12,11 @@  module TcInstDcls ( tcInstDecls1, tcInstDeclsDeriv, tcInstDecls2 ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude -import HsSyn+import GHC.Hs import TcBinds import TcTyClsDecls import TcTyDecls ( addTyConsToGblEnv )@@ -29,6 +29,8 @@ import TcHsSyn import TcMType import TcType+import Constraint+import TcOrigin import BuildTyCl import Inst import ClsInst( AssocInstInfo(..), isNotAssociated )@@ -239,7 +241,7 @@ end up with non-inlined dictionaries that look like     $df = $cop |> blah which adds an extra indirection to every use, which seems stupid.  See-Trac #4138 for an example (although the regression reported there+#4138 for an example (although the regression reported there wasn't due to the indirection).  There is an awkward wrinkle though: we want to be very@@ -254,7 +256,7 @@ pragma on the dfun itself; after all, it ends up being just a cast.  There is one more dark corner to the INLINE story, even more deeply-buried.  Consider this (Trac #3772):+buried.  Consider this (#3772):      class DeepSeq a => C a where       gen :: Int -> a@@ -392,17 +394,14 @@ --   (DerivDecl) to check and process all derived class instances. tcInstDeclsDeriv   :: [DerivInfo]-  -> [LTyClDecl GhcRn]   -> [LDerivDecl GhcRn]   -> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn)-tcInstDeclsDeriv datafam_deriv_infos tyclds derivds+tcInstDeclsDeriv deriv_infos derivds   = do th_stage <- getStage -- See Note [Deriving inside TH brackets]        if isBrackStage th_stage        then do { gbl_env <- getGblEnv                ; return (gbl_env, bagToList emptyBag, emptyValBindsOut) }-       else do { data_deriv_infos <- mkDerivInfos tyclds-               ; let deriv_infos = datafam_deriv_infos ++ data_deriv_infos-               ; (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds+       else do { (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds                ; return (tcg_env, bagToList info_bag, valbinds) }  addClsInsts :: [InstInfo GhcRn] -> TcM a -> TcM a@@ -433,7 +432,7 @@  there is really no point in generating the derived code for deriving( Show) and then type-checking it. This will happen at the call site-anyway, and the type check should never fail!  Moreover (Trac #6005)+anyway, and the type check should never fail!  Moreover (#6005) the scoping of the generated code inside the bracket does not seem to work out. @@ -461,7 +460,7 @@   = do { (insts, fam_insts, deriv_infos) <- tcClsInstDecl (L loc decl)        ; return (insts, fam_insts, deriv_infos) } -tcLocalInstDecl (L _ (XInstDecl _)) = panic "tcLocalInstDecl"+tcLocalInstDecl (L _ (XInstDecl nec)) = noExtCon nec  tcClsInstDecl :: LClsInstDecl GhcRn               -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])@@ -472,8 +471,7 @@                                   , cid_datafam_insts = adts }))   = setSrcSpan loc                      $     addErrCtxt (instDeclCtxt1 hs_ty)  $-    do  { traceTc "tcLocalInstDecl" (ppr hs_ty)-        ; dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty+    do  { dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty         ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty              -- NB: tcHsClsInstType does checkValidInstance @@ -539,7 +537,7 @@                                         . dfid_eqn                                         . unLoc) adts) -tcClsInstDecl (L _ (XClsInstDecl _)) = panic "tcClsInstDecl"+tcClsInstDecl (L _ (XClsInstDecl nec)) = noExtCon nec  {- ************************************************************************@@ -660,10 +658,10 @@        ; gadt_syntax <- dataDeclChecks fam_name new_or_data hs_ctxt hs_cons           -- Do /not/ check that the number of patterns = tyConArity fam_tc           -- See [Arity of data families] in FamInstEnv-        ; (qtvs, pats, res_kind, stupid_theta)-             <- tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs-                                fixity hs_ctxt hs_pats m_ksig hs_cons+             <- tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs+                                    fixity hs_ctxt hs_pats m_ksig hs_cons+                                    new_or_data         -- Eta-reduce the axiom if possible        -- Quite tricky: see Note [Eta-reduction for data families]@@ -677,15 +675,18 @@                  -- Put the eta-removed tyvars at the end                  -- Remember, qtvs is in arbitrary order, except kind vars are                  -- first, so there is no reason to suppose that the eta_tvs-                 -- (obtained from the pats) are at the end (Trac #11148)+                 -- (obtained from the pats) are at the end (#11148) -       -- Eta-expand the representation tycon until it has reult kind *+       -- Eta-expand the representation tycon until it has result+       -- kind `TYPE r`, for some `r`. If UnliftedNewtypes is not enabled, we+       -- go one step further and ensure that it has kind `TYPE 'LiftedRep`.+       --        -- See also Note [Arity of data families] in FamInstEnv        -- NB: we can do this after eta-reducing the axiom, because if        --     we did it before the "extra" tvs from etaExpandAlgTyCon        --     would always be eta-reduced        ; (extra_tcbs, final_res_kind) <- etaExpandAlgTyCon full_tcbs res_kind-       ; checkTc (tcIsLiftedTypeKind final_res_kind) (badKindSig True res_kind)+       ; checkDataKindSig (DataInstanceSort new_or_data) final_res_kind        ; let extra_pats  = map (mkTyVarTy . binderVar) extra_tcbs              all_pats    = pats `chkAppend` extra_pats              orig_res_ty = mkTyConApp fam_tc all_pats@@ -703,9 +704,10 @@         ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) ->            do { data_cons <- tcExtendTyVarEnv qtvs $-                             -- For H98 decls, the tyvars scope-                             -- over the data constructors-                             tcConDecls rec_rep_tc ty_binders orig_res_ty hs_cons+                  -- For H98 decls, the tyvars scope+                  -- over the data constructors+                  tcConDecls rec_rep_tc new_or_data ty_binders final_res_kind+                             orig_res_ty hs_cons                ; rep_tc_name <- newFamInstTyConName lfam_name pats               ; axiom_name  <- newFamInstAxiomName lfam_name [pats]@@ -722,7 +724,7 @@                       -- NB: Use the full ty_binders from the pats. See bullet toward                       -- the end of Note [Data type families] in TyCon                     rep_tc   = mkAlgTyCon rep_tc_name-                                          ty_binders liftedTypeKind+                                          ty_binders final_res_kind                                           (map (const Nominal) ty_binders)                                           (fmap unLoc cType) stupid_theta                                           tc_rhs parent@@ -746,6 +748,7 @@                L _ []    -> Nothing                L _ preds ->                  Just $ DerivInfo { di_rep_tc  = rep_tc+                                  , di_scoped_tvs = mkTyVarNamePairs (tyConTyVars rep_tc)                                   , di_clauses = preds                                   , di_ctxt    = tcMkDataFamInstCtxt decl } @@ -779,57 +782,78 @@ tcDataFamInstDecl _ _ = panic "tcDataFamInstDecl"  ------------------------tcDataFamHeader :: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr GhcRn]-                -> LexicalFixity -> LHsContext GhcRn-                -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> [LConDecl GhcRn]-                -> TcM ([TyVar], [Type], Kind, ThetaType)--- The "header" is the part other than the data constructors themselves--- e.g.  data instance D [a] :: * -> * where ...+tcDataFamInstHeader+    :: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr GhcRn]+    -> LexicalFixity -> LHsContext GhcRn+    -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> [LConDecl GhcRn]+    -> NewOrData+    -> TcM ([TyVar], [Type], Kind, ThetaType)+-- The "header" of a data family instance is the part other than+-- the data constructors themselves+--    e.g.  data instance D [a] :: * -> * where ... -- Here the "header" is the bit before the "where"-tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity hs_ctxt hs_pats m_ksig hs_cons-  = do { (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty, res_kind)))+tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity+                    hs_ctxt hs_pats m_ksig hs_cons new_or_data+  = do { (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty)))             <- pushTcLevelM_                                $                solveEqualities                              $                bindImplicitTKBndrs_Q_Skol imp_vars          $                bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $                do { stupid_theta <- tcHsContext hs_ctxt                   ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats-                    -- Ensure that the instance is consistent with its-                    -- parent class++                  -- Ensure that the instance is consistent+                  -- with its parent class                   ; addConsistencyConstraints mb_clsinfo lhs_ty-                  ; mapM_ (wrapLocM_ kcConDecl) hs_cons++                  -- Add constraints from the result signature                   ; res_kind <- tc_kind_sig m_ksig-                  ; lhs_ty <- checkExpectedKind YesSaturation pp_lhs lhs_ty lhs_kind res_kind-                  ; return (stupid_theta, lhs_ty, res_kind) } +                  -- Add constraints from the data constructors+                  ; kcConDecls new_or_data res_kind hs_cons++                  ; lhs_ty <- checkExpectedKind_pp pp_lhs lhs_ty lhs_kind res_kind+                  ; return (stupid_theta, lhs_ty) }+        -- See TcTyClsDecls Note [Generalising in tcFamTyPatsGuts]        -- This code (and the stuff immediately above) is very similar-       -- to that in tcFamTyInstEqnGuts.  Maybe we should abstract the+       -- to that in tcTyFamInstEqnGuts.  Maybe we should abstract the        -- common code; but for the moment I concluded that it's        -- clearer to duplicate it.  Still, if you fix a bug here,        -- check there too!        ; let scoped_tvs = imp_tvs ++ exp_tvs        ; dvs  <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs)-       ; qtvs <- quantifyTyVars emptyVarSet dvs+       ; qtvs <- quantifyTyVars dvs         -- Zonk the patterns etc into the Type world        ; (ze, qtvs)   <- zonkTyBndrs qtvs-       ; lhs_ty       <- zonkTcTypeToTypeX ze lhs_ty-       ; res_kind     <- zonkTcTypeToTypeX ze res_kind+              -- See Note [Unifying data family kinds] about the discardCast+       ; lhs_ty       <- zonkTcTypeToTypeX ze (discardCast lhs_ty)        ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta         -- Check that type patterns match the class instance head-       ; let pats = unravelFamInstPats lhs_ty-       ; return (qtvs, pats, res_kind, stupid_theta) }+       -- The call to splitTyConApp_maybe here is just an inlining of+       -- the body of unravelFamInstPats.+       ; pats <- case splitTyConApp_maybe lhs_ty of+           Just (_, pats) -> pure pats+           Nothing -> pprPanic "tcDataFamInstHeader" (ppr lhs_ty)+       ; return (qtvs, pats, typeKind lhs_ty, stupid_theta) }+          -- See Note [Unifying data family kinds] about why we need typeKind here   where     fam_name  = tyConName fam_tc     data_ctxt = DataKindCtxt fam_name     pp_lhs    = pprHsFamInstLHS fam_name mb_bndrs hs_pats fixity hs_ctxt     exp_bndrs = mb_bndrs `orElse` [] -    -- See Note [Result kind signature for a data family instance]+    -- See Note [Implementation of UnliftedNewtypes] in TcTyClsDecls, wrinkle (2).     tc_kind_sig Nothing-      = return liftedTypeKind+      = do { unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes+           ; if unlifted_newtypes && new_or_data == NewType+               then newOpenTypeKind+               else pure liftedTypeKind+           }++    -- See Note [Result kind signature for a data family instance]     tc_kind_sig (Just hs_kind)       = do { sig_kind <- tcLHsKindSig data_ctxt hs_kind            ; let (tvs, inner_kind) = tcSplitForAllTys sig_kind@@ -847,6 +871,36 @@ Thus: skolemise away. cf. Inst.deeplySkolemise and TcUnify.tcSkolemise Examples in indexed-types/should_compile/T12369 +Note [Unifying data family kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we kind-check a newtype instance with -XUnliftedNewtypes, we must+unify the kind of the data family with any declared kind in the instance+declaration. For example:++  data Color = Red | Blue+  type family Interpret (x :: Color) :: RuntimeRep where+    Interpret 'Red = 'IntRep+    Interpret 'Blue = 'WordRep+  data family Foo (x :: Color) :: TYPE (Interpret x)+  newtype instance Foo 'Red :: TYPE IntRep where+    FooRedC :: Int# -> Foo 'Red++We end up unifying `TYPE (Interpret 'Red)` (the kind of Foo, instantiated+with 'Red) and `TYPE IntRep` (the declared kind of the instance). This+unification succeeds, resulting in a coercion. The big question: what to+do with this coercion? Answer: nothing! A kind annotation on a newtype instance+is always redundant (except, perhaps, in that it helps guide unification). We+have a definitive kind for the data family from the data family declaration,+and so we learn nothing really new from the kind signature on an instance.+We still must perform this unification (done in the call to checkExpectedKind+toward the beginning of tcDataFamInstHeader), but the result is unhelpful. If there+is a cast, it will wrap the lhs_ty, and so we just drop it before splitting the+lhs_ty to reveal the underlying patterns. Because of the potential of dropping+a cast like this, we just use typeKind in the result instead of propagating res_kind+from above.++This Note is wrinkle (3) in Note [Implementation of UnliftedNewtypes] in TcTyClsDecls.+ Note [Eta-reduction for data families] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -894,7 +948,7 @@   'k1' and 'k2', as well as 'b'.    The skolemise bit is done in tc_kind_sig, while the instantiate bit-  is done by the checkExpectedKind that immediately follows.+  is done by tcFamTyPats.  * Very fiddly point.  When we eta-reduce to      axiom AxDrep forall a b. D [(a,b]] = Drep a b@@ -905,7 +959,7 @@   the TyConBndrVis on Drep's arguments. In particular do we have     (forall (k::*). blah) or (* -> blah)? -  We must match whatever D does!  In Trac #15817 we had+  We must match whatever D does!  In #15817 we had       data family X a :: forall k. * -> *   -- Note: a forall that is not used       data instance X Int b = MkX @@ -1044,14 +1098,14 @@                      --    con_app_scs  = MkD ty1 ty2 sc1 sc2                      --    con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2              con_app_tys  = mkHsWrap (mkWpTyApps inst_tys)-                                  (HsConLikeOut noExt (RealDataCon dict_constr))+                                  (HsConLikeOut noExtField (RealDataCon dict_constr))                        -- NB: We *can* have covars in inst_tys, in the case of                        -- promoted GADT constructors.               con_app_args = foldl' app_to_meth con_app_tys sc_meth_ids               app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc-             app_to_meth fun meth_id = HsApp noExt (L loc fun)+             app_to_meth fun meth_id = HsApp noExtField (L loc fun)                                             (L loc (wrapId arg_wrapper meth_id))               inst_tv_tys = mkTyVarTys inst_tyvars@@ -1065,13 +1119,13 @@                     -- Newtype dfuns just inline unconditionally,                     -- so don't attempt to specialise them -             export = ABE { abe_ext  = noExt+             export = ABE { abe_ext  = noExtField                           , abe_wrap = idHsWrapper                           , abe_poly = dfun_id_w_prags                           , abe_mono = self_dict                           , abe_prags = dfun_spec_prags }                           -- NB: see Note [SPECIALISE instance pragmas]-             main_bind = AbsBinds { abs_ext = noExt+             main_bind = AbsBinds { abs_ext = noExtField                                   , abs_tvs = inst_tyvars                                   , abs_ev_vars = dfun_ev_vars                                   , abs_exports = [export]@@ -1118,7 +1172,7 @@    is_newtype  = isNewTyCon clas_tc  wrapId :: HsWrapper -> IdP (GhcPass id) -> HsExpr (GhcPass id)-wrapId wrapper id = mkHsWrap wrapper (HsVar noExt (noLoc id))+wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLoc id))  {- Note [Typechecking plan for instance declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1214,15 +1268,16 @@            ; sc_top_name  <- newName (mkSuperDictAuxOcc n (getOccName cls))            ; sc_ev_id     <- newEvVar sc_pred            ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm-           ; let sc_top_ty = mkInvForAllTys tyvars (mkLamTypes dfun_evs sc_pred)+           ; let sc_top_ty = mkInvForAllTys tyvars $+                             mkPhiTy (map idType dfun_evs) sc_pred                  sc_top_id = mkLocalId sc_top_name sc_top_ty-                 export = ABE { abe_ext  = noExt+                 export = ABE { abe_ext  = noExtField                               , abe_wrap = idHsWrapper                               , abe_poly = sc_top_id                               , abe_mono = sc_ev_id                               , abe_prags = noSpecPrags }                  local_ev_binds = TcEvBinds ev_binds_var-                 bind = AbsBinds { abs_ext      = noExt+                 bind = AbsBinds { abs_ext      = noExtField                                  , abs_tvs      = tyvars                                  , abs_ev_vars  = dfun_evs                                  , abs_exports  = [export]@@ -1251,11 +1306,11 @@ {- Note [Recursive superclasses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See Trac #3731, #4809, #5751, #5913, #6117, #6161, which all+See #3731, #4809, #5751, #5913, #6117, #6161, which all describe somewhat more complicated situations, but ones encountered in practice. -See also tests tcrun020, tcrun021, tcrun033, and Trac #11427.+See also tests tcrun020, tcrun021, tcrun033, and #11427.  ----- THE PROBLEM -------- The problem is that it is all too easy to create a class whose@@ -1320,7 +1375,7 @@ But for (i2) that isn't the case, so we must add an explicit, and perhaps surprising, (Ord r) argument to the instance declaration. -Here's another example from Trac #6161:+Here's another example from #6161:         class       Super a => Duper a  where ...        class Duper (Fam a) => Foo a    where ...@@ -1515,12 +1570,12 @@                              mkLHsWrap lam_wrapper (error_rhs dflags)            ; return (meth_id, meth_bind, Nothing) }       where-        error_rhs dflags = L inst_loc $ HsApp noExt error_fun (error_msg dflags)+        error_rhs dflags = L inst_loc $ HsApp noExtField error_fun (error_msg dflags)         error_fun    = L inst_loc $                        wrapId (mkWpTyApps                                 [ getRuntimeRep meth_tau, meth_tau])                               nO_METHOD_BINDING_ERROR_ID-        error_msg dflags = L inst_loc (HsLit noExt (HsStringPrim NoSourceText+        error_msg dflags = L inst_loc (HsLit noExtField (HsStringPrim NoSourceText                                               (unsafeMkByteString (error_string dflags))))         meth_tau     = funResultTy (piResultTys (idType sel_id) inst_tys)         error_string dflags = showSDoc dflags@@ -1607,10 +1662,8 @@  1. In tcMethods (which typechecks method bindings), disable    -Winaccessible-code.-2. When creating Implications during typechecking, record the Env-   (through ic_env) at the time of creation. Since the Env also stores-   DynFlags, this will remember that -Winaccessible-code was disabled over-   the scope of that implication.+2. When creating Implications during typechecking, record this flag+   (in ic_warn_inaccessible) at the time of creation. 3. After typechecking comes error reporting, where GHC must decide how to    report inaccessible code to the user, on an Implication-by-Implication    basis. If an Implication's DynFlags indicate that -Winaccessible-code was@@ -1648,14 +1701,14 @@        ; spec_prags     <- tcSpecPrags global_meth_id prags          ; let specs  = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags-              export = ABE { abe_ext   = noExt+              export = ABE { abe_ext   = noExtField                            , abe_poly  = global_meth_id                            , abe_mono  = local_meth_id                            , abe_wrap  = idHsWrapper                            , abe_prags = specs }                local_ev_binds = TcEvBinds ev_binds_var-              full_bind = AbsBinds { abs_ext      = noExt+              full_bind = AbsBinds { abs_ext      = noExtField                                    , abs_tvs      = tyvars                                    , abs_ev_vars  = dfun_ev_vars                                    , abs_exports  = [export]@@ -1698,14 +1751,14 @@         ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind -       ; let export = ABE { abe_ext   = noExt+       ; let export = ABE { abe_ext   = noExtField                           , abe_poly  = local_meth_id                           , abe_mono  = inner_id                           , abe_wrap  = hs_wrap                           , abe_prags = noSpecPrags }         ; return (unitBag $ L (getLoc meth_bind) $-                 AbsBinds { abs_ext = noExt, abs_tvs = [], abs_ev_vars = []+                 AbsBinds { abs_ext = noExtField, abs_tvs = [], abs_ev_vars = []                           , abs_exports = [export]                           , abs_binds = tc_bind, abs_ev_binds = []                           , abs_sig = True }) }@@ -1851,7 +1904,7 @@         ; dm_id <- tcLookupId dm_name         ; let inline_prag = idInlinePragma dm_id               inline_prags | isAnyInlinePragma inline_prag-                           = [noLoc (InlineSig noExt fn inline_prag)]+                           = [noLoc (InlineSig noExtField fn inline_prag)]                            | otherwise                            = []                  -- Copy the inline pragma (if any) from the default method@@ -1871,7 +1924,7 @@        ; return (bind, inline_prags) }   where     mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn-    mk_vta fun ty = noLoc (HsAppType noExt fun (mkEmptyWildCardBndrs $ nlHsParTy+    mk_vta fun ty = noLoc (HsAppType noExtField fun (mkEmptyWildCardBndrs $ nlHsParTy                                                 $ noLoc $ XHsType $ NHsCoreTy ty))        -- NB: use visible type application        -- See Note [Default methods in instances]@@ -1928,8 +1981,8 @@    fooIntInt = $dmfoo @Int @Int  Lacking VTA we'd get ambiguity errors involving the default method.  This applies-equally to vanilla default methods (Trac #1061) and generic default methods-(Trac #12220).+equally to vanilla default methods (#1061) and generic default methods+(#12220).  Historical note: before we had VTA we had to generate post-type-checked code, which took a lot more code, and didn't work for@@ -2046,7 +2099,7 @@    * The specialised dictionary $s$dfIxPair is very much needed, in case we     call a function that takes a dictionary, but in a context where the-    specialised dictionary can be used.  See Trac #7797.+    specialised dictionary can be used.  See #7797.    * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because     it still has a DFunUnfolding.  See Note [ClassOp/DFun selection]@@ -2080,7 +2133,7 @@         ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty         ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }   where-    spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag)+    spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag)  tcSpecInst _  _ = panic "tcSpecInst"
compiler/typecheck/TcInstDcls.hs-boot view
@@ -5,7 +5,7 @@  module TcInstDcls ( tcInstDecls1 ) where -import HsSyn+import GHC.Hs import TcRnTypes import TcEnv( InstInfo ) import TcDeriv
compiler/typecheck/TcInteract.hs view
@@ -5,7 +5,7 @@      solveSimpleWanteds,  -- Solves Cts   ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude import BasicTypes ( SwapFlag(..), isSwapped,@@ -35,6 +35,9 @@ import Outputable  import TcRnTypes+import Constraint+import Predicate+import TcOrigin import TcSMonad import Bag import MonadUtils ( concatMapM, foldlM )@@ -97,7 +100,7 @@  * When floating an equality outwards, we don't need to worry about floating its    associated flattening constraints. - * Another tricky case becomes easy: Trac #4935+ * Another tricky case becomes easy: #4935        type instance F True a b = a        type instance F False a b = b @@ -223,7 +226,7 @@  solveSimples cts   = {-# SCC "solveSimples" #-}-    do { updWorkListTcS (\wl -> foldrBag extendWorkListCt wl cts)+    do { updWorkListTcS (\wl -> foldr extendWorkListCt wl cts)        ; solve_loop }   where     solve_loop@@ -559,9 +562,10 @@      ev_id_w = ctEvEvId ev_w       different_level_strategy  -- Both Given-       | isIPPred pred, lvl_w > lvl_i = KeepWork-       | lvl_w < lvl_i                = KeepWork-       | otherwise                    = KeepInert+       | isIPPred pred = if lvl_w > lvl_i then KeepWork  else KeepInert+       | otherwise     = if lvl_w > lvl_i then KeepInert else KeepWork+       -- See Note [Replacement vs keeping] (the different-level bullet)+       -- For the isIPPred case see Note [Shadowing of Implicit Parameters]       same_level_strategy binds -- Both Given        | GivenOrigin (InstSC s_i) <- ctLocOrigin loc_i@@ -628,7 +632,7 @@            Binds:     d3 = sc_sel d2, d2 = sc_sel d1            Work item: d3 :: C a            Then it'd be ridiculous to replace d1 with d3 in the inert set!-           Hence the findNeedEvVars test.  See Trac #14774.+           Hence the findNeedEvVars test.  See #14774.    * Finally, when there is still a choice, use KeepInert rather than     KeepWork, for two reasons:@@ -744,7 +748,7 @@  {- Note [Solving irreducible equalities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (Trac #14333)+Consider (#14333)   [G] a b ~R# c d   [W] c d ~R# a b Clearly we should be able to solve this! Even though the constraints are@@ -905,7 +909,7 @@  Note [Shortcut solving: type families] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have (Trac #13943)+Suppose we have (#13943)   class Take (n :: Nat) where ...   instance {-# OVERLAPPING #-}                    Take 0 where ..   instance {-# OVERLAPPABLE #-} (Take (n - 1)) => Take n where ..@@ -1008,7 +1012,7 @@   solved_dicts state  ensures that we remember what we have already   tried to solve to avoid looping. -* As Trac #15164 showed, it can be important to exploit sharing between+* As #15164 showed, it can be important to exploit sharing between   goals. E.g. To solve G we may need G1 and G2. To solve G1 we may need H;   and to solve G2 we may need H. If we don't spot this sharing we may   solve H twice; and if this pattern repeats we may get exponentially bad@@ -1180,8 +1184,12 @@         inert_loc  = ctEvLoc inert_ev         derived_loc = work_loc { ctl_depth  = ctl_depth work_loc `maxSubGoalDepth`                                               ctl_depth inert_loc-                               , ctl_origin = FunDepOrigin1 work_pred  work_loc-                                                            inert_pred inert_loc }+                               , ctl_origin = FunDepOrigin1 work_pred+                                                            (ctLocOrigin work_loc)+                                                            (ctLocSpan work_loc)+                                                            inert_pred+                                                            (ctLocOrigin inert_loc)+                                                            (ctLocSpan inert_loc) }  {- **********************************************************************@@ -1246,6 +1254,9 @@  So the inner binding for ?x::Bool *overrides* the outer one. +See ticket #17104 for a rather tricky example of this overriding+behaviour.+ All this works for the normal cases but it has an odd side effect in some pathological programs like this: -- This is accepted, the second parameter shadows@@ -1332,59 +1343,61 @@     || not (isImprovable work_ev)   = return () -  | not (null improvement_eqns)-  = do { traceTcS "interactFunEq improvements: " $-         vcat [ text "Eqns:" <+> ppr improvement_eqns-              , text "Candidates:" <+> ppr funeqs_for_tc-              , text "Inert eqs:" <+> ppr ieqs ]-       ; emitFunDepDeriveds improvement_eqns }-   | otherwise-  = return ()+  = do { eqns <- improvement_eqns+       ; if not (null eqns)+         then do { traceTcS "interactFunEq improvements: " $+                   vcat [ text "Eqns:" <+> ppr eqns+                        , text "Candidates:" <+> ppr funeqs_for_tc+                        , text "Inert eqs:" <+> ppr (inert_eqs inerts) ]+                 ; emitFunDepDeriveds eqns }+         else return () }    where-    ieqs          = inert_eqs inerts     funeqs        = inert_funeqs inerts     funeqs_for_tc = findFunEqsByTyCon funeqs fam_tc-    rhs           = lookupFlattenTyVar ieqs fsk     work_loc      = ctEvLoc work_ev     work_pred     = ctEvPred work_ev     fam_inj_info  = tyConInjectivityInfo fam_tc      ---------------------    improvement_eqns :: [FunDepEqn CtLoc]+    improvement_eqns :: TcS [FunDepEqn CtLoc]     improvement_eqns       | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc       =    -- Try built-in families, notably for arithmethic-         concatMap (do_one_built_in ops) funeqs_for_tc+        do { rhs <- rewriteTyVar fsk+           ; concatMapM (do_one_built_in ops rhs) funeqs_for_tc }        | Injective injective_args <- fam_inj_info       =    -- Try improvement from type families with injectivity annotations-        concatMap (do_one_injective injective_args) funeqs_for_tc+        do { rhs <- rewriteTyVar fsk+           ; concatMapM (do_one_injective injective_args rhs) funeqs_for_tc }        | otherwise-      = []+      = return []      ---------------------    do_one_built_in ops (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk, cc_ev = inert_ev })-      = mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs-                                             (lookupFlattenTyVar ieqs ifsk))+    do_one_built_in ops rhs (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk, cc_ev = inert_ev })+      = do { inert_rhs <- rewriteTyVar ifsk+           ; return $ mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs inert_rhs) } -    do_one_built_in _ _ = pprPanic "interactFunEq 1" (ppr fam_tc)+    do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc)      --------------------     -- See Note [Type inference for type families with injectivity]-    do_one_injective inj_args (CFunEqCan { cc_tyargs = inert_args-                                         , cc_fsk = ifsk, cc_ev = inert_ev })+    do_one_injective inj_args rhs (CFunEqCan { cc_tyargs = inert_args+                                             , cc_fsk = ifsk, cc_ev = inert_ev })       | isImprovable inert_ev-      , rhs `tcEqType` lookupFlattenTyVar ieqs ifsk-      = mk_fd_eqns inert_ev $-            [ Pair arg iarg-            | (arg, iarg, True) <- zip3 args inert_args inj_args ]+      = do { inert_rhs <- rewriteTyVar ifsk+           ; return $ if rhs `tcEqType` inert_rhs+                      then mk_fd_eqns inert_ev $+                             [ Pair arg iarg+                             | (arg, iarg, True) <- zip3 args inert_args inj_args ]+                      else [] }       | otherwise-      = []+      = return [] -    do_one_injective _ _ = pprPanic "interactFunEq 2" (ppr fam_tc)+    do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc)      --------------------     mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn CtLoc]@@ -1671,7 +1684,7 @@   newtype N b = MkN b and we want to get alpha := N b. -See also Trac #15144, which was caused by unifying a representational+See also #15144, which was caused by unifying a representational equality (in the unflattener).  @@ -1688,7 +1701,7 @@  Danger 1: If we send the original constraint on down the pipeline            it may react with an instance declaration, and in delicate            situations (when a Given overlaps with an instance) that-           may produce new insoluble goals: see Trac #4952+           may produce new insoluble goals: see #4952   Danger 2: If we don't rewrite the constraint, it may re-react            with the same thing later, and produce the same equality@@ -1763,7 +1776,7 @@ the Wanted matches the second instance, so we never get as far as the fundeps. -Trac #7875 is a case in point.+#7875 is a case in point. -}  emitFunDepDeriveds :: [FunDepEqn CtLoc] -> TcS ()@@ -1856,9 +1869,66 @@ kind is not Constraint, such as (forall a. F a ~# b)  See- * Note [Evidence for quantified constraints] in Type+ * Note [Evidence for quantified constraints] in Predicate  * Note [Equality superclasses in quantified constraints]    in TcCanonical++Note [Flatten when discharging CFunEqCan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have the following scenario (#16512):++type family LV (as :: [Type]) (b :: Type) = (r :: Type) | r -> as b where+  LV (a ': as) b = a -> LV as b++[WD] w1 :: LV as0 (a -> b) ~ fmv1 (CFunEqCan)+[WD] w2 :: fmv1 ~ (a -> fmv2) (CTyEqCan)+[WD] w3 :: LV as0 b ~ fmv2 (CFunEqCan)++We start with w1. Because LV is injective, we wish to see if the RHS of the+equation matches the RHS of the CFunEqCan. The RHS of a CFunEqCan is always an+fmv, so we "look through" to get (a -> fmv2). Then we run tcUnifyTyWithTFs.+That performs the match, but it allows a type family application (such as the+LV in the RHS of the equation) to match with anything. (See "Injective type+families" by Stolarek et al., HS'15, Fig. 2) The matching succeeds, which+means we can improve as0 (and b, but that's not interesting here). However,+because the RHS of w1 can't see through fmv2 (we have no way of looking up a+LHS of a CFunEqCan from its RHS, and this use case isn't compelling enough),+we invent a new unification variable here. We thus get (as0 := a : as1).+Rewriting:++[WD] w1 :: LV (a : as1) (a -> b) ~ fmv1+[WD] w2 :: fmv1 ~ (a -> fmv2)+[WD] w3 :: LV (a : as1) b ~ fmv2++We can now reduce both CFunEqCans, using the equation for LV. We get++[WD] w2 :: (a -> LV as1 (a -> b)) ~ (a -> a -> LV as1 b)++Now we decompose (and flatten) to++[WD] w4 :: LV as1 (a -> b) ~ fmv3+[WD] w5 :: fmv3 ~ (a -> fmv1)+[WD] w6 :: LV as1 b ~ fmv4++which is exactly where we started. These goals really are insoluble, but+we would prefer not to loop. We thus need to find a way to bump the reduction+depth, so that we can detect the loop and abort.++The key observation is that we are performing a reduction. We thus wish+to bump the level when discharging a CFunEqCan. Where does this bumped+level go, though? It can't just go on the reduct, as that's a type. Instead,+it must go on any CFunEqCans produced after flattening. We thus flatten+when discharging, making sure that the level is bumped in the new+fun-eqs. The flattening happens in reduce_top_fun_eq and the level+is bumped when setting up the FlatM monad in TcFlatten.runFlatten.+(This bumping will happen for call sites other than this one, but that+makes sense -- any constraints emitted by the flattener are offshoots+the work item and should have a higher level. We don't have any test+cases that require the bumping in this other cases, but it's convenient+and causes no harm to bump at every flatten.)++Test case: typecheck/should_fail/T16512a+ -}  --------------------@@ -1887,6 +1957,7 @@                   -> TcS (StopOrContinue Ct) -- We have found an applicable top-level axiom: use it to reduce -- Precondition: fsk is not free in rhs_ty+-- ax_co :: F tys ~ rhs_ty, where F tys is the LHS of the old_ev reduce_top_fun_eq old_ev fsk (ax_co, rhs_ty)   | not (isDerived old_ev)  -- Precondition of shortCutReduction   , Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty@@ -1901,7 +1972,11 @@   = ASSERT2( not (fsk `elemVarSet` tyCoVarsOfType rhs_ty)            , ppr old_ev $$ ppr rhs_ty )            -- Guaranteed by Note [FunEq occurs-check principle]-    do { dischargeFunEq old_ev fsk ax_co rhs_ty+    do { (rhs_xi, flatten_co) <- flatten FM_FlattenAll old_ev rhs_ty+             -- flatten_co :: rhs_xi ~ rhs_ty+             -- See Note [Flatten when discharging CFunEqCan]+       ; let total_co = ax_co `mkTcTransCo` mkTcSymCo flatten_co+       ; dischargeFunEq old_ev fsk total_co rhs_xi        ; traceTcS "doTopReactFunEq" $          vcat [ text "old_ev:" <+> ppr old_ev               , nest 2 (text ":=") <+> ppr ax_co ]@@ -1915,16 +1990,16 @@   = return ()    | otherwise-  = do { ieqs <- getInertEqs-       ; fam_envs <- getFamInstEnvs-       ; eqns <- improve_top_fun_eqs fam_envs fam_tc args-                                    (lookupFlattenTyVar ieqs fsk)-       ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr fsk+  = do { fam_envs <- getFamInstEnvs+       ; rhs <- rewriteTyVar fsk+       ; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs+       ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs                                           , ppr eqns ])        ; mapM_ (unifyDerived loc Nominal) eqns }   where-    loc = ctEvLoc ev  -- ToDo: this location is wrong; it should be FunDepOrigin2-                      -- See Trac #14778+    loc = bumpCtLocDepth (ctEvLoc ev)+        -- ToDo: this location is wrong; it should be FunDepOrigin2+        -- See #14778  improve_top_fun_eqs :: FamInstEnvs                     -> TyCon -> [TcType] -> TcType@@ -1988,7 +2063,7 @@                   -- If the current substitution bind [k -> *], and                   -- one of the un-substituted tyvars is (a::k), we'd better                   -- be sure to apply the current substitution to a's kind.-                  -- Hence instFlexiX.   Trac #13135 was an example.+                  -- Hence instFlexiX.   #13135 was an example.               ; return [ Pair (substTyUnchecked subst ax_arg) arg                         -- NB: the ax_arg part is on the left@@ -2100,12 +2175,12 @@  Examples: -* Trac #5837 has [G] a ~ TF (a,Int), with an instance+* #5837 has [G] a ~ TF (a,Int), with an instance     type instance TF (a,b) = (TF a, TF b)   This readily loops when solving givens.  But with the FunEq occurs   check principle, it rapidly gets stuck which is fine. -* Trac #12444 is a good example, explained in comment:2.  We have+* #12444 is a good example, explained in comment:2.  We have     type instance F (Succ x) = Succ (F x)     [W] alpha ~ Succ (F alpha)   If we allow the reduction to happen, we get an infinite loop@@ -2127,7 +2202,7 @@ Note [Improvement orientation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A very delicate point is the orientation of derived equalities-arising from injectivity improvement (Trac #12522).  Suppse we have+arising from injectivity improvement (#12522).  Suppse we have   type family F x = t | t -> x   type instance F (a, Int) = (Int, G a) where G is injective; and wanted constraints@@ -2248,9 +2323,8 @@         ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc         ; case lkup_res of                OneInst { cir_what = what }-                  -> do { unless (safeOverlap what) $-                          insertSafeOverlapFailureTcS work_item-                        ; when (isWanted ev) $ addSolvedDict ev cls xis+                  -> do { insertSafeOverlapFailureTcS what work_item+                        ; addSolvedDict what ev cls xis                         ; chooseInstance work_item lkup_res }                _  ->  -- NoInstance or NotSure                      do { when (isImprovable ev) $@@ -2342,7 +2416,7 @@  {- Note [Instances in no-evidence implications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In Trac #15290 we had+In #15290 we had   [G] forall p q. Coercible p q => Coercible (m p) (m q))   [W] forall <no-ev> a. m (Int, IntStateT m a)                           ~R#@@ -2441,7 +2515,7 @@ The end effect is that, much as we do for overlapping instances, we delay choosing a class instance if there is a possibility of another instance OR a given to match our constraint later on. This fixes-Trac #4981 and #5002.+#4981 and #5002.  Other notes: @@ -2463,10 +2537,10 @@   constraints, but it is possible. I've added a test case in   typecheck/should-compile/GivenOverlapping.hs -* Another "live" example is Trac #10195; another is #10177.+* Another "live" example is #10195; another is #10177.  * We ignore the overlap problem if -XIncoherentInstances is in force:-  see Trac #6002 for a worked-out example where this makes a+  see #6002 for a worked-out example where this makes a   difference.  * Moreover notice that our goals here are different than the goals of@@ -2487,7 +2561,7 @@   and suppose we have -XNoMonoLocalBinds, so that we attempt to find the most   general type for 'v'.  When generalising v's type we'll simplify its   Q [alpha] constraint, but we don't have Q [a] in the 'givens', so we-  will use the instance declaration after all. Trac #11948 was a case+  will use the instance declaration after all. #11948 was a case   in point.  All of this is disgustingly delicate, so to discourage people from writing@@ -2530,7 +2604,7 @@   superclasses invert the instance;  e.g.       class (c1, c2) => (% c1, c2 %)       instance (c1, c2) => (% c1, c2 %)-  Example in Trac #14218+  Example in #14218  Exammples: T5853, T10432, T5315, T9222, T2627b, T3028b @@ -2606,4 +2680,3 @@         qtv_set = mkVarSet qtvs         this_unif = mightMatchLater qpred (ctEvLoc ev) pred loc         (matches, unif) = match_local_inst qcis-
compiler/typecheck/TcMType.hs view
@@ -6,7 +6,7 @@ Monadic type operations  This module contains monadic operations over types that contain-mutable type variables+mutable type variables. -}  {-# LANGUAGE CPP, TupleSections, MultiWayIf #-}@@ -48,11 +48,13 @@   unpackCoercionHole, unpackCoercionHole_maybe,   checkCoercionHole, +  newImplication,+   --------------------------------   -- Instantiation   newMetaTyVars, newMetaTyVarX, newMetaTyVarsX,   newMetaTyVarTyVars, newMetaTyVarTyVarX,-  newTyVarTyVar, newTauTyVar, newSkolemTyVar, newWildCardX,+  newTyVarTyVar, newPatSigTyVar, newSkolemTyVar, newWildCardX,   tcInstType,   tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt,   tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX,@@ -65,14 +67,13 @@   tidyEvVar, tidyCt, tidySkolemInfo,     zonkTcTyVar, zonkTcTyVars,   zonkTcTyVarToTyVar, zonkTyVarTyVarPairs,-  zonkTyCoVarsAndFV, zonkTcTypeAndFV,+  zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkDTyCoVarSetAndFV,   zonkTyCoVarsAndFVList,   candidateQTyVarsOfType,  candidateQTyVarsOfKind,   candidateQTyVarsOfTypes, candidateQTyVarsOfKinds,-  CandidatesQTvs(..), delCandidates, candidateKindVars,-  skolemiseQuantifiedTyVar, defaultTyVar,-  quantifyTyVars,-  zonkTcTyCoVarBndr, zonkTyConBinders,+  CandidatesQTvs(..), delCandidates, candidateKindVars, partitionCandidates,+  zonkAndSkolemise, skolemiseQuantifiedTyVar,+  defaultTyVar, quantifyTyVars, isQuantifiableTv,   zonkTcType, zonkTcTypes, zonkCo,   zonkTyCoVarKind, @@ -80,28 +81,32 @@   zonkId, zonkCoVar,   zonkCt, zonkSkolemInfo, -  tcGetGlobalTyCoVars,+  skolemiseUnboundMetaTyVar,    ------------------------------   -- Levity polymorphism   ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr   ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  -- friends: import GhcPrelude  import TyCoRep+import TyCoPpr import TcType import Type import TyCon import Coercion import Class import Var+import Predicate+import TcOrigin  -- others: import TcRnMonad        -- TcType, amongst others+import Constraint import TcEvidence import Id import Name@@ -117,7 +122,9 @@ import Bag import Pair import UniqSet+import DynFlags import qualified GHC.LanguageExtensions as LangExt+import BasicTypes ( TypeOrKind(..) )  import Control.Monad import Maybes@@ -141,14 +148,15 @@ kind_var_occ = mkOccName tvName "k"  newMetaKindVar :: TcM TcKind-newMetaKindVar = do { uniq <- newUnique-                    ; details <- newMetaDetails TauTv-                    ; let kv = mkTcTyVar (mkKindName uniq) liftedTypeKind details-                    ; traceTc "newMetaKindVar" (ppr kv)-                    ; return (mkTyVarTy kv) }+newMetaKindVar+  = do { details <- newMetaDetails TauTv+       ; uniq <- newUnique+       ; let kv = mkTcTyVar (mkKindName uniq) liftedTypeKind details+       ; traceTc "newMetaKindVar" (ppr kv)+       ; return (mkTyVarTy kv) }  newMetaKindVars :: Int -> TcM [TcKind]-newMetaKindVars n = mapM (\ _ -> newMetaKindVar) (nOfThem n ())+newMetaKindVars n = replicateM n newMetaKindVar  {- ************************************************************************@@ -172,8 +180,8 @@ -- Deals with both equality and non-equality predicates newWanted orig t_or_k pty   = do loc <- getCtLocM orig t_or_k-       d <- if isEqPred pty then HoleDest  <$> newCoercionHole pty-                            else EvVarDest <$> newEvVar pty+       d <- if isEqPrimPred pty then HoleDest  <$> newCoercionHole pty+                                else EvVarDest <$> newEvVar pty        return $ CtWanted { ctev_dest = d                          , ctev_pred = pty                          , ctev_nosh = WDeriv@@ -286,6 +294,22 @@     IrredPred {}    -> mkVarOccFS (fsLit "irred")     ForAllPred {}   -> mkVarOccFS (fsLit "df") +-- | Create a new 'Implication' with as many sensible defaults for its fields+-- as possible. Note that the 'ic_tclvl', 'ic_binds', and 'ic_info' fields do+-- /not/ have sensible defaults, so they are initialized with lazy thunks that+-- will 'panic' if forced, so one should take care to initialize these fields+-- after creation.+--+-- This is monadic to look up the 'TcLclEnv', which is used to initialize+-- 'ic_env', and to set the -Winaccessible-code flag. See+-- Note [Avoid -Winaccessible-code when deriving] in TcInstDcls.+newImplication :: TcM Implication+newImplication+  = do env <- getLclEnv+       warn_inaccessible <- woptM Opt_WarnInaccessibleCode+       return (implicationPrototype { ic_env = env+                                    , ic_warn_inaccessible = warn_inaccessible })+ {- ************************************************************************ *                                                                      *@@ -383,7 +407,7 @@ By defining ExpType, separately from Type, we can achieve goals 1 and 2 statically. -See also [wiki:Typechecking]+See also [wiki:typechecking]  Note [TcLevel of ExpType] ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -661,42 +685,118 @@ * In partial type signatures, see Note [Quantified variables in partial type signatures] -} --- see Note [TyVarTv]+newMetaTyVarName :: FastString -> TcM Name+-- Makes a /System/ Name, which is eagerly eliminated by+-- the unifier; see TcUnify.nicer_to_update_tv1, and+-- TcCanonical.canEqTyVarTyVar (nicer_to_update_tv2)+newMetaTyVarName str+  = do { uniq <- newUnique+       ; return (mkSystemName uniq (mkTyVarOccFS str)) }++cloneMetaTyVarName :: Name -> TcM Name+cloneMetaTyVarName name+  = do { uniq <- newUnique+       ; return (mkSystemName uniq (nameOccName name)) }+         -- See Note [Name of an instantiated type variable]++{- Note [Name of an instantiated type variable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+At the moment we give a unification variable a System Name, which+influences the way it is tidied; see TypeRep.tidyTyVarBndr.++Note [Unification variables need fresh Names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Whenever we allocate a unification variable (MetaTyVar) we give+it a fresh name.   #16221 is a very tricky case that illustrates+why this is important:++   data SameKind :: k -> k -> *+   data T0 a = forall k2 (b :: k2). MkT0 (SameKind a b) !Int++When kind-checking T0, we give (a :: kappa1). Then, in kcConDecl+we allocate a unification variable kappa2 for k2, and then we+end up unifying kappa1 := kappa2 (because of the (SameKind a b).++Now we generalise over kappa2; but if kappa2's Name is k2,+we'll end up giving T0 the kind forall k2. k2 -> *.  Nothing+directly wrong with that but when we typecheck the data constrautor+we end up giving it the type+  MkT0 :: forall k1 (a :: k1) k2 (b :: k2).+          SameKind @k2 a b -> Int -> T0 @{k2} a+which is bogus.  The result type should be T0 @{k1} a.++And there no reason /not/ to clone the Name when making a+unification variable.  So that's what we do.+-}++newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar+-- Make a new meta tyvar out of thin air+newAnonMetaTyVar meta_info kind+  = do  { let s = case meta_info of+                        TauTv       -> fsLit "t"+                        FlatMetaTv  -> fsLit "fmv"+                        FlatSkolTv  -> fsLit "fsk"+                        TyVarTv      -> fsLit "a"+        ; name    <- newMetaTyVarName s+        ; details <- newMetaDetails meta_info+        ; let tyvar = mkTcTyVar name kind details+        ; traceTc "newAnonMetaTyVar" (ppr tyvar)+        ; return tyvar }++-- makes a new skolem tv+newSkolemTyVar :: Name -> Kind -> TcM TcTyVar+newSkolemTyVar name kind+  = do { lvl <- getTcLevel+       ; return (mkTcTyVar name kind (SkolemTv lvl False)) }+ newTyVarTyVar :: Name -> Kind -> TcM TcTyVar+-- See Note [TyVarTv]+-- See Note [Unification variables need fresh Names] newTyVarTyVar name kind   = do { details <- newMetaDetails TyVarTv-       ; let tyvar = mkTcTyVar name kind details+       ; uniq <- newUnique+       ; let name' = name `setNameUnique` uniq+             tyvar = mkTcTyVar name' kind details+         -- Don't use cloneMetaTyVar, which makes a SystemName+         -- We want to keep the original more user-friendly Name+         -- In practical terms that means that in error messages,+         -- when the Name is tidied we get 'a' rather than 'a0'        ; traceTc "newTyVarTyVar" (ppr tyvar)        ; return tyvar } +newPatSigTyVar :: Name -> Kind -> TcM TcTyVar+newPatSigTyVar name kind+  = do { details <- newMetaDetails TauTv+       ; uniq <- newUnique+       ; let name' = name `setNameUnique` uniq+             tyvar = mkTcTyVar name' kind details+         -- Don't use cloneMetaTyVar;+         -- same reasoning as in newTyVarTyVar+       ; traceTc "newPatSigTyVar" (ppr tyvar)+       ; return tyvar } --- makes a new skolem tv-newSkolemTyVar :: Name -> Kind -> TcM TcTyVar-newSkolemTyVar name kind = do { lvl <- getTcLevel-                              ; return (mkTcTyVar name kind (SkolemTv lvl False)) }+cloneAnonMetaTyVar :: MetaInfo -> TyVar -> TcKind -> TcM TcTyVar+-- Make a fresh MetaTyVar, basing the name+-- on that of the supplied TyVar+cloneAnonMetaTyVar info tv kind+  = do  { details <- newMetaDetails info+        ; name    <- cloneMetaTyVarName (tyVarName tv)+        ; let tyvar = mkTcTyVar name kind details+        ; traceTc "cloneAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar))+        ; return tyvar }  newFskTyVar :: TcType -> TcM TcTyVar newFskTyVar fam_ty-  = do { uniq <- newUnique-       ; ref  <- newMutVar Flexi-       ; tclvl <- getTcLevel-       ; let details = MetaTv { mtv_info  = FlatSkolTv-                              , mtv_ref   = ref-                              , mtv_tclvl = tclvl }-             name = mkMetaTyVarName uniq (fsLit "fsk")+  = do { details <- newMetaDetails FlatSkolTv+       ; name <- newMetaTyVarName (fsLit "fsk")        ; return (mkTcTyVar name (tcTypeKind fam_ty) details) }  newFmvTyVar :: TcType -> TcM TcTyVar -- Very like newMetaTyVar, except sets mtv_tclvl to one less -- so that the fmv is untouchable. newFmvTyVar fam_ty-  = do { uniq <- newUnique-       ; ref  <- newMutVar Flexi-       ; tclvl <- getTcLevel-       ; let details = MetaTv { mtv_info  = FlatMetaTv-                              , mtv_ref   = ref-                              , mtv_tclvl = tclvl }-             name = mkMetaTyVarName uniq (fsLit "s")+  = do { details <- newMetaDetails FlatMetaTv+       ; name <- newMetaTyVarName (fsLit "s")        ; return (mkTcTyVar name (tcTypeKind fam_ty) details) }  newMetaDetails :: MetaInfo -> TcM TcTyVarDetails@@ -710,10 +810,9 @@ cloneMetaTyVar :: TcTyVar -> TcM TcTyVar cloneMetaTyVar tv   = ASSERT( isTcTyVar tv )-    do  { uniq <- newUnique-        ; ref  <- newMutVar Flexi-        ; let name'    = setNameUnique (tyVarName tv) uniq-              details' = case tcTyVarDetails tv of+    do  { ref  <- newMutVar Flexi+        ; name' <- cloneMetaTyVarName (tyVarName tv)+        ; let details' = case tcTyVarDetails tv of                            details@(MetaTv {}) -> details { mtv_ref = ref }                            _ -> pprPanic "cloneMetaTyVar" (ppr tv)               tyvar = mkTcTyVar name' (tyVarKind tv) details'@@ -784,10 +883,8 @@   = do { meta_details <- readMutVar ref;        -- Zonk kinds to allow the error check to work        ; zonked_tv_kind <- zonkTcType tv_kind-       ; zonked_ty      <- zonkTcType ty-       ; let zonked_ty_kind = tcTypeKind zonked_ty  -- Need to zonk even before typeKind;-                                                    -- otherwise, we can panic in piResultTy-             kind_check_ok = tcIsConstraintKind zonked_tv_kind+       ; zonked_ty_kind <- zonkTcType ty_kind+       ; let kind_check_ok = tcIsConstraintKind zonked_tv_kind                           || tcEqKind zonked_ty_kind zonked_tv_kind              -- Hack alert! tcIsConstraintKind: see TcHsType              -- Note [Extra-constraint holes in partial type signatures]@@ -813,6 +910,7 @@        ; writeMutVar ref (Indirect ty) }   where     tv_kind = tyVarKind tyvar+    ty_kind = tcTypeKind ty      tv_lvl = tcTyVarLevel tyvar     ty_lvl = tcTypeLevel ty@@ -860,52 +958,7 @@ that can't ever appear in user code, so we're safe! -} -newTauTyVar :: Name -> Kind -> TcM TcTyVar-newTauTyVar name kind-  = do { details <- newMetaDetails TauTv-       ; let tyvar = mkTcTyVar name kind details-       ; traceTc "newTauTyVar" (ppr tyvar)-       ; return tyvar } --mkMetaTyVarName :: Unique -> FastString -> Name--- Makes a /System/ Name, which is eagerly eliminated by--- the unifier; see TcUnify.nicer_to_update_tv1, and--- TcCanonical.canEqTyVarTyVar (nicer_to_update_tv2)-mkMetaTyVarName uniq str = mkSystemName uniq (mkTyVarOccFS str)--newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar--- Make a new meta tyvar out of thin air-newAnonMetaTyVar meta_info kind-  = do  { uniq <- newUnique-        ; let name = mkMetaTyVarName uniq s-              s = case meta_info of-                        TauTv       -> fsLit "t"-                        FlatMetaTv  -> fsLit "fmv"-                        FlatSkolTv  -> fsLit "fsk"-                        TyVarTv      -> fsLit "a"-        ; details <- newMetaDetails meta_info-        ; let tyvar = mkTcTyVar name kind details-        ; traceTc "newAnonMetaTyVar" (ppr tyvar)-        ; return tyvar }--cloneAnonMetaTyVar :: MetaInfo -> TyVar -> TcKind -> TcM TcTyVar--- Same as newAnonMetaTyVar, but use a supplied TyVar as the source of the print-name-cloneAnonMetaTyVar info tv kind-  = do  { uniq    <- newUnique-        ; details <- newMetaDetails info-        ; let name = mkSystemName uniq (getOccName tv)-                       -- See Note [Name of an instantiated type variable]-              tyvar = mkTcTyVar name kind details-        ; traceTc "cloneAnonMetaTyVar" (ppr tyvar)-        ; return tyvar }--{- Note [Name of an instantiated type variable]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-At the moment we give a unification variable a System Name, which-influences the way it is tidied; see TypeRep.tidyTyVarBndr.--}- newFlexiTyVar :: Kind -> TcM TcTyVar newFlexiTyVar kind = newAnonMetaTyVar TauTv kind @@ -915,7 +968,7 @@     return (mkTyVarTy tc_tyvar)  newFlexiTyVarTys :: Int -> Kind -> TcM [TcType]-newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind)+newFlexiTyVarTys n kind = replicateM n (newFlexiTyVarTy kind)  newOpenTypeKind :: TcM TcKind newOpenTypeKind@@ -967,22 +1020,21 @@         ; return (subst1, new_tv) }   where     substd_kind = substTyUnchecked subst (tyVarKind tv)-      -- NOTE: Trac #12549 is fixed so we could use+      -- NOTE: #12549 is fixed so we could use       -- substTy here, but the tc_infer_args problem       -- is not yet fixed so leaving as unchecked for now.       -- OLD NOTE:       -- Unchecked because we call newMetaTyVarX from       -- tcInstTyBinder, which is called from tcInferApps       -- which does not yet take enough trouble to ensure-      -- the in-scope set is right; e.g. Trac #12785 trips+      -- the in-scope set is right; e.g. #12785 trips       -- if we use substTy here  newMetaTyVarTyAtLevel :: TcLevel -> TcKind -> TcM TcType newMetaTyVarTyAtLevel tc_lvl kind-  = do  { uniq <- newUnique-        ; ref  <- newMutVar Flexi-        ; let name = mkMetaTyVarName uniq (fsLit "p")-              details = MetaTv { mtv_info  = TauTv+  = do  { ref  <- newMutVar Flexi+        ; name <- newMetaTyVarName (fsLit "p")+        ; let details = MetaTv { mtv_info  = TauTv                                , mtv_ref   = ref                                , mtv_tclvl = tc_lvl }         ; return (mkTyVarTy (mkTcTyVar name kind details)) }@@ -1000,14 +1052,17 @@ we default the kind variables to *.  So, to support this defaulting, and only for that reason, when-collecting the free vars of a type, prior to quantifying, we must keep-the type and kind variables separate.+collecting the free vars of a type (in candidateQTyVarsOfType and friends),+prior to quantifying, we must keep the type and kind variables separate.  But what does that mean in a system where kind variables /are/ type variables? It's a fairly arbitrary distinction based on how the variables appear:    - "Kind variables" appear in the kind of some other free variable+    or in the kind of a locally quantified type variable+    (forall (a :: kappa). ...) or in the kind of a coercion+    (a |> (co :: kappa1 ~ kappa2)).       These are the ones we default to * if -XPolyKinds is off @@ -1056,7 +1111,7 @@   accumulating-parameter style for candidateQTyVarsOfType so that we   add variables one at a time, left to right.  That means we tend to   produce the variables in left-to-right order.  This is just to make-  it bit more predicatable for the programmer.+  it bit more predictable for the programmer.  Note [Naughty quantification candidates] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1095,8 +1150,8 @@ the final zonk (which zaps any lingering metavariables to Any).  We do this eager zapping in candidateQTyVars, which always precedes-generalisation, because at that moment we have a clear picture of-what skolems are in scope.+generalisation, because at that moment we have a clear picture of what+skolems are in scope within the type itself (e.g. that 'forall arg').  Wrinkle: @@ -1107,7 +1162,7 @@ to treat it as naughty. We say "strictly greater than" because the call to candidateQTyVars is made outside the bumped TcLevel, as stated in the comment to candidateQTyVarsOfType. The level check is done in go_tv-in collect_cant_qtvs. Skipping this check caused #16517.+in collect_cand_qtvs. Skipping this check caused #16517.  -} @@ -1116,9 +1171,19 @@   -- See Note [CandidatesQTvs determinism and order]   --   -- Invariants:-  --   * All variables stored here are MetaTvs. No exceptions.   --   * All variables are fully zonked, including their kinds+  --   * All variables are at a level greater than the ambient level+  --     See Note [Use level numbers for quantification]   --+  -- This *can* contain skolems. For example, in `data X k :: k -> Type`+  -- we need to know that the k is a dependent variable. This is done+  -- by collecting the candidates in the kind after skolemising. It also+  -- comes up when generalizing a associated type instance, where instance+  -- variables are skolems. (Recall that associated type instances are generalized+  -- independently from their enclosing class instance, and the associated+  -- type instance may be generalized by more, fewer, or different variables+  -- than the class instance.)+  --   = DV { dv_kvs :: DTyVarSet    -- "kind" metavariables (dependent)        , dv_tvs :: DTyVarSet    -- "type" metavariables (non-dependent)          -- A variable may appear in both sets@@ -1127,9 +1192,8 @@          -- See Note [Dependent type variables]         , dv_cvs :: CoVarSet-         -- These are covars. We will *not* quantify over these, but-         -- we must make sure also not to quantify over any cv's kinds,-         -- so we include them here as further direction for quantifyTyVars+         -- These are covars. Included only so that we don't repeatedly+         -- look at covars' kinds in accumulator. Not used by quantifyTyVars.     }  instance Semi.Semigroup CandidatesQTvs where@@ -1153,6 +1217,14 @@ candidateKindVars :: CandidatesQTvs -> TyVarSet candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs) +partitionCandidates :: CandidatesQTvs -> (TyVar -> Bool) -> (DTyVarSet, CandidatesQTvs)+partitionCandidates dvs@(DV { dv_kvs = kvs, dv_tvs = tvs }) pred+  = (extracted, dvs { dv_kvs = rest_kvs, dv_tvs = rest_tvs })+  where+    (extracted_kvs, rest_kvs) = partitionDVarSet pred kvs+    (extracted_tvs, rest_tvs) = partitionDVarSet pred tvs+    extracted = extracted_kvs `unionDVarSet` extracted_tvs+ -- | Gathers free variables to use as quantification candidates (in -- 'quantifyTyVars'). This might output the same var -- in both sets, if it's used in both a type and a kind.@@ -1214,20 +1286,20 @@     -----------------     go :: CandidatesQTvs -> TcType -> TcM CandidatesQTvs     -- Uses accumulating-parameter style-    go dv (AppTy t1 t2)    = foldlM go dv [t1, t2]-    go dv (TyConApp _ tys) = foldlM go dv tys-    go dv (FunTy arg res)  = foldlM go dv [arg, res]-    go dv (LitTy {})       = return dv-    go dv (CastTy ty co)   = do dv1 <- go dv ty-                                collect_cand_qtvs_co bound dv1 co-    go dv (CoercionTy co)  = collect_cand_qtvs_co bound dv co+    go dv (AppTy t1 t2)     = foldlM go dv [t1, t2]+    go dv (TyConApp _ tys)  = foldlM go dv tys+    go dv (FunTy _ arg res) = foldlM go dv [arg, res]+    go dv (LitTy {})        = return dv+    go dv (CastTy ty co)    = do dv1 <- go dv ty+                                 collect_cand_qtvs_co bound dv1 co+    go dv (CoercionTy co)   = collect_cand_qtvs_co bound dv co      go dv (TyVarTy tv)-      | is_bound tv = return dv-      | otherwise   = do { m_contents <- isFilledMetaTyVar_maybe tv-                         ; case m_contents of-                             Just ind_ty -> go dv ind_ty-                             Nothing     -> go_tv dv tv }+      | is_bound tv      = return dv+      | otherwise        = do { m_contents <- isFilledMetaTyVar_maybe tv+                              ; case m_contents of+                                  Just ind_ty -> go dv ind_ty+                                  Nothing     -> go_tv dv tv }      go dv (ForAllTy (Bndr tv _) ty)       = do { dv1 <- collect_cand_qtvs True bound dv (tyVarKind tv)@@ -1246,27 +1318,38 @@       = do { tv_kind <- zonkTcType (tyVarKind tv)                  -- This zonk is annoying, but it is necessary, both to                  -- ensure that the collected candidates have zonked kinds-                 -- (Trac #15795) and to make the naughty check+                 -- (#15795) and to make the naughty check                  -- (which comes next) works correctly             ; cur_lvl <- getTcLevel-           ; if tcTyVarLevel tv `strictlyDeeperThan` cur_lvl &&-                   -- this tyvar is from an outer context: see Wrinkle-                   -- in Note [Naughty quantification candidates]+           ; if |  tcTyVarLevel tv <= cur_lvl+                -> return dv   -- this variable is from an outer context; skip+                               -- See Note [Use level numbers ofor quantification] -                intersectsVarSet bound (tyCoVarsOfType tv_kind)+                |  intersectsVarSet bound (tyCoVarsOfType tv_kind)+                   -- the tyvar must not be from an outer context, but we have+                   -- already checked for this.+                   -- See Note [Naughty quantification candidates]+                -> do { traceTc "Zapping naughty quantifier" $+                          vcat [ ppr tv <+> dcolon <+> ppr tv_kind+                               , text "bound:" <+> pprTyVars (nonDetEltsUniqSet bound)+                               , text "fvs:" <+> pprTyVars (nonDetEltsUniqSet $+                                                            tyCoVarsOfType tv_kind) ] -             then -- See Note [Naughty quantification candidates]-                  do { traceTc "Zapping naughty quantifier" (pprTyVar tv)-                     ; writeMetaTyVar tv (anyTypeOfKind tv_kind)-                     ; collect_cand_qtvs True bound dv tv_kind }+                      ; writeMetaTyVar tv (anyTypeOfKind tv_kind) -             else do { let tv' = tv `setTyVarKind` tv_kind-                           dv' | is_dep    = dv { dv_kvs = kvs `extendDVarSet` tv' }-                               | otherwise = dv { dv_tvs = tvs `extendDVarSet` tv' }-                               -- See Note [Order of accumulation]-                     ; collect_cand_qtvs True emptyVarSet dv' tv_kind } }+                      -- See Note [Recurring into kinds for candidateQTyVars]+                      ; collect_cand_qtvs True bound dv tv_kind } +                |  otherwise+                -> do { let tv' = tv `setTyVarKind` tv_kind+                            dv' | is_dep    = dv { dv_kvs = kvs `extendDVarSet` tv' }+                                | otherwise = dv { dv_tvs = tvs `extendDVarSet` tv' }+                                -- See Note [Order of accumulation]++                        -- See Note [Recurring into kinds for candidateQTyVars]+                      ; collect_cand_qtvs True bound dv' tv_kind } }+ collect_cand_qtvs_co :: VarSet -- bound variables                      -> CandidatesQTvs -> Coercion                      -> TcM CandidatesQTvs@@ -1291,10 +1374,11 @@     go_co dv (KindCo co)           = go_co dv co     go_co dv (SubCo co)            = go_co dv co -    go_co dv (HoleCo hole) = do m_co <- unpackCoercionHole_maybe hole-                                case m_co of-                                  Just co -> go_co dv co-                                  Nothing -> go_cv dv (coHoleCoVar hole)+    go_co dv (HoleCo hole)+      = do m_co <- unpackCoercionHole_maybe hole+           case m_co of+             Just co -> go_co dv co+             Nothing -> go_cv dv (coHoleCoVar hole)      go_co dv (CoVarCo cv) = go_cv dv cv @@ -1314,7 +1398,9 @@     go_cv dv@(DV { dv_cvs = cvs }) cv       | is_bound cv         = return dv       | cv `elemVarSet` cvs = return dv-      | otherwise           = collect_cand_qtvs True emptyVarSet++        -- See Note [Recurring into kinds for candidateQTyVars]+      | otherwise           = collect_cand_qtvs True bound                                     (dv { dv_cvs = cvs `extendVarSet` cv })                                     (idType cv) @@ -1339,6 +1425,44 @@  Note that the unitDVarSet/mappend implementation would not be wrong against any specification -- just suboptimal and confounding to users.++Note [Recurring into kinds for candidateQTyVars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+First, read Note [Closing over free variable kinds] in TyCoFVs, paying+attention to the end of the Note about using an empty bound set when+traversing a variable's kind.++That Note concludes with the recommendation that we empty out the bound+set when recurring into the kind of a type variable. Yet, we do not do+this here. I have two tasks in order to convince you that this code is+right. First, I must show why it is safe to ignore the reasoning in that+Note. Then, I must show why is is necessary to contradict the reasoning in+that Note.++Why it is safe: There can be no+shadowing in the candidateQ... functions: they work on the output of+type inference, which is seeded by the renamer and its insistence to+use different Uniques for different variables. (In contrast, the Core+functions work on the output of optimizations, which may introduce+shadowing.) Without shadowing, the problem studied by+Note [Closing over free variable kinds] in TyCoFVs cannot happen.++Why it is necessary:+Wiping the bound set would be just plain wrong here. Consider++  forall k1 k2 (a :: k1). Proxy k2 (a |> (hole :: k1 ~# k2))++We really don't want to think k1 and k2 are free here. (It's true that we'll+never be able to fill in `hole`, but we don't want to go off the rails just+because we have an insoluble coercion hole.) So: why is it wrong to wipe+the bound variables here but right in Core? Because the final statement+in Note [Closing over free variable kinds] in TyCoFVs is wrong: not+every variable is either free or bound. A variable can be a hole, too!+The reasoning in that Note then breaks down.++And the reasoning applies just as well to free non-hole variables, so we+retain the bound set always.+ -}  {- *********************************************************************@@ -1353,17 +1477,8 @@ are about to wrap in a forall.  It takes these free type/kind variables (partitioned into dependent and-non-dependent variables) and-  1. Zonks them and remove globals and covars-  2. Extends kvs1 with free kind vars in the kinds of tvs (removing globals)-  3. Calls skolemiseQuantifiedTyVar on each--Step (2) is often unimportant, because the kind variable is often-also free in the type.  Eg-     Typeable k (a::k)-has free vars {k,a}.  But the type (see Trac #7916)-    (f::k->*) (a::k)-has free vars {f,a}, but we must add 'k' as well! Hence step (2).+non-dependent variables) skolemises metavariables with a TcLevel greater+than the ambient level (see Note [Use level numbers of quantification]).  * This function distinguishes between dependent and non-dependent   variables only to keep correct defaulting behavior with -XNoPolyKinds.@@ -1373,6 +1488,48 @@     - a coercion variable (or any tv mentioned in the kind of a covar)     - a runtime-rep variable +Note [Use level numbers for quantification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The level numbers assigned to metavariables are very useful. Not only+do they track touchability (Note [TcLevel and untouchable type variables]+in TcType), but they also allow us to determine which variables to+generalise. The rule is this:++  When generalising, quantify only metavariables with a TcLevel greater+  than the ambient level.++This works because we bump the level every time we go inside a new+source-level construct. In a traditional generalisation algorithm, we+would gather all free variables that aren't free in an environment.+However, if a variable is in that environment, it will always have a lower+TcLevel: it came from an outer scope. So we can replace the "free in+environment" check with a level-number check.++Here is an example:++  f x = x + (z True)+    where+      z y = x * x++We start by saying (x :: alpha[1]). When inferring the type of z, we'll+quickly discover that z :: alpha[1]. But it would be disastrous to+generalise over alpha in the type of z. So we need to know that alpha+comes from an outer environment. By contrast, the type of y is beta[2],+and we are free to generalise over it. What's the difference between+alpha[1] and beta[2]? Their levels. beta[2] has the right TcLevel for+generalisation, and so we generalise it. alpha[1] does not, and so+we leave it alone.++Note that not *every* variable with a higher level will get generalised,+either due to the monomorphism restriction or other quirks. See, for+example, the code in TcSimplify.decideMonoTyVars and in+TcHsType.kindGeneralizeSome, both of which exclude certain otherwise-eligible+variables from being generalised.++Using level numbers for quantification is implemented in the candidateQTyVars...+functions, by adding only those variables with a level strictly higher than+the ambient level to the set of candidates.+ Note [quantifyTyVars determinism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The results of quantifyTyVars are wrapped in a forall and can end up in the@@ -1388,60 +1545,39 @@ -}  quantifyTyVars-  :: TcTyCoVarSet     -- Global tvs; already zonked-  -> CandidatesQTvs   -- See Note [Dependent type variables]+  :: CandidatesQTvs   -- See Note [Dependent type variables]                       -- Already zonked   -> TcM [TcTyVar] -- See Note [quantifyTyVars] -- Can be given a mixture of TcTyVars and TyVars, in the case of --   associated type declarations. Also accepts covars, but *never* returns any.-quantifyTyVars gbl_tvs-               dvs@(DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs, dv_cvs = covars })-  = do { outer_tclvl <- getTcLevel-       ; traceTc "quantifyTyVars 1" (vcat [ppr outer_tclvl, ppr dvs, ppr gbl_tvs])-       ; let co_tvs = closeOverKinds covars-             mono_tvs = gbl_tvs `unionVarSet` co_tvs-              -- NB: All variables in the kind of a covar must not be-              -- quantified over, as we don't quantify over the covar.+-- According to Note [Use level numbers for quantification] and the+-- invariants on CandidateQTvs, we do not have to filter out variables+-- free in the environment here. Just quantify unconditionally, subject+-- to the restrictions in Note [quantifyTyVars].+quantifyTyVars dvs@(DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs })+       -- short-circuit common case+  | isEmptyDVarSet dep_tkvs+  , isEmptyDVarSet nondep_tkvs+  = do { traceTc "quantifyTyVars has nothing to quantify" empty+       ; return [] } -             dep_kvs = dVarSetElemsWellScoped $-                       dep_tkvs `dVarSetMinusVarSet` mono_tvs-                       -- dVarSetElemsWellScoped: put the kind variables into+  | otherwise+  = do { traceTc "quantifyTyVars 1" (ppr dvs)++       ; let dep_kvs     = scopedSort $ dVarSetElems dep_tkvs+                       -- scopedSort: put the kind variables into                        --    well-scoped order.                        --    E.g.  [k, (a::k)] not the other way roud -             nondep_tvs = dVarSetElems $-                          (nondep_tkvs `minusDVarSet` dep_tkvs)-                           `dVarSetMinusVarSet` mono_tvs+             nondep_tvs  = dVarSetElems (nondep_tkvs `minusDVarSet` dep_tkvs)                  -- See Note [Dependent type variables]                  -- The `minus` dep_tkvs removes any kind-level vars                  --    e.g. T k (a::k)   Since k appear in a kind it'll                  --    be in dv_kvs, and is dependent. So remove it from                  --    dv_tvs which will also contain k-                 -- No worry about dependent covars here;-                 --    they are all in dep_tkvs                  -- NB kinds of tvs are zonked by zonkTyCoVarsAndFV -       -- This block uses level numbers to decide what to quantify-       -- and emits a warning if the two methods do not give the same answer-       ; let dep_kvs2    = dVarSetElemsWellScoped $-                           filterDVarSet (quantifiableTv outer_tclvl) dep_tkvs-             nondep_tvs2 = filter (quantifiableTv outer_tclvl) $-                           dVarSetElems (nondep_tkvs `minusDVarSet` dep_tkvs)--             all_ok = dep_kvs == dep_kvs2 && nondep_tvs == nondep_tvs2-             bad_msg = hang (text "Quantification by level numbers would fail")-                          2 (vcat [ text "Outer level =" <+> ppr outer_tclvl-                                  , text "dep_tkvs ="    <+> ppr dep_tkvs-                                  , text "co_vars ="     <+> vcat [ ppr cv <+> dcolon <+> ppr (varType cv)-                                                                  | cv <- nonDetEltsUniqSet covars ]-                                  , text "co_tvs ="      <+> ppr co_tvs-                                  , text "dep_kvs ="     <+> ppr dep_kvs-                                  , text "dep_kvs2 ="    <+> ppr dep_kvs2-                                  , text "nondep_tvs ="  <+> ppr nondep_tvs-                                  , text "nondep_tvs2 =" <+> ppr nondep_tvs2 ])-       ; WARN( not all_ok, bad_msg ) return ()-              -- In the non-PolyKinds case, default the kind variables              -- to *, and zonk the tyvars as usual.  Notice that this              -- may make quantifyTyVars return a shorter list@@ -1455,9 +1591,7 @@            -- now refer to the dep_kvs'         ; traceTc "quantifyTyVars 2"-           (vcat [ text "globals:"    <+> ppr gbl_tvs-                 , text "mono_tvs:"   <+> ppr mono_tvs-                 , text "nondep:"     <+> pprTyVars nondep_tvs+           (vcat [ text "nondep:"     <+> pprTyVars nondep_tvs                  , text "dep:"        <+> pprTyVars dep_kvs                  , text "dep_kvs'"    <+> pprTyVars dep_kvs'                  , text "nondep_tvs'" <+> pprTyVars nondep_tvs' ])@@ -1477,11 +1611,10 @@       = return Nothing   -- this can happen for a covar that's associated with                          -- a coercion hole. Test case: typecheck/should_compile/T2494 -      | not (isTcTyVar tkv)  -- I don't think this can ever happen.-                             -- Hence the assert-      = ASSERT2( False, text "quantifying over a TyVar" <+> ppr tkv)-        return (Just tkv)-+      | not (isTcTyVar tkv)+      = return (Just tkv)  -- For associated types in a class with a standalone+                           -- kind signature, we have the class variables in+                           -- scope, and they are TyVars not TcTyVars       | otherwise       = do { deflt_done <- defaultTyVar default_kind tkv            ; case deflt_done of@@ -1489,15 +1622,33 @@                False -> do { tv <- skolemiseQuantifiedTyVar tkv                            ; return (Just tv) } } -quantifiableTv :: TcLevel   -- Level of the context, outside the quantification-               -> TcTyVar-               -> Bool-quantifiableTv outer_tclvl tcv-  | isTcTyVar tcv  -- Might be a CoVar; change this when gather covars separtely+isQuantifiableTv :: TcLevel   -- Level of the context, outside the quantification+                 -> TcTyVar+                 -> Bool+isQuantifiableTv outer_tclvl tcv+  | isTcTyVar tcv  -- Might be a CoVar; change this when gather covars separately   = tcTyVarLevel tcv > outer_tclvl   | otherwise   = False +zonkAndSkolemise :: TcTyCoVar -> TcM TcTyCoVar+-- A tyvar binder is never a unification variable (TauTv),+-- rather it is always a skolem. It *might* be a TyVarTv.+-- (Because non-CUSK type declarations use TyVarTvs.)+-- Regardless, it may have a kind that has not yet been zonked,+-- and may include kind unification variables.+zonkAndSkolemise tyvar+  | isTyVarTyVar tyvar+     -- We want to preserve the binding location of the original TyVarTv.+     -- This is important for error messages. If we don't do this, then+     -- we get bad locations in, e.g., typecheck/should_fail/T2688+  = do { zonked_tyvar <- zonkTcTyVarToTyVar tyvar+       ; skolemiseQuantifiedTyVar zonked_tyvar }++  | otherwise+  = ASSERT2( isImmutableTyVar tyvar || isCoVar tyvar, pprTyVar tyvar )+    zonkTyCoVarKind tyvar+ skolemiseQuantifiedTyVar :: TcTyVar -> TcM TcTyVar -- The quantified type variables often include meta type variables -- we want to freeze them into ordinary type variables@@ -1532,7 +1683,7 @@   | isTyVarTyVar tv     -- Do not default TyVarTvs. Doing so would violate the invariants     -- on TyVarTvs; see Note [Signature skolems] in TcType.-    -- Trac #13343 is an example; #14555 is another+    -- #13343 is an example; #14555 is another     -- See Note [Inferring kinds for type declarations] in TcTyClsDecls   = return False @@ -1543,15 +1694,14 @@        ; writeMetaTyVar tv liftedRepTy        ; return True } -  | default_kind                 -- -XNoPolyKinds and this is a kind var-  = do { default_kind_var tv     -- so default it to * if possible-       ; return True }+  | default_kind            -- -XNoPolyKinds and this is a kind var+  = default_kind_var tv     -- so default it to * if possible    | otherwise   = return False    where-    default_kind_var :: TyVar -> TcM ()+    default_kind_var :: TyVar -> TcM Bool        -- defaultKindVar is used exclusively with -XNoPolyKinds        -- See Note [Defaulting with -XNoPolyKinds]        -- It takes an (unconstrained) meta tyvar and defaults it.@@ -1559,11 +1709,20 @@     default_kind_var kv       | isLiftedTypeKind (tyVarKind kv)       = do { traceTc "Defaulting a kind var to *" (ppr kv)-           ; writeMetaTyVar kv liftedTypeKind }+           ; writeMetaTyVar kv liftedTypeKind+           ; return True }       | otherwise-      = addErr (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv')-                     , text "of kind:" <+> ppr (tyVarKind kv')-                     , text "Perhaps enable PolyKinds or add a kind signature" ])+      = do { addErr (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv')+                          , text "of kind:" <+> ppr (tyVarKind kv')+                          , text "Perhaps enable PolyKinds or add a kind signature" ])+           -- We failed to default it, so return False to say so.+           -- Hence, it'll get skolemised.  That might seem odd, but we must either+           -- promote, skolemise, or zap-to-Any, to satisfy TcHsType+           --    Note [Recipe for checking a signature]+           -- Otherwise we get level-number assertion failures. It doesn't matter much+           -- because we are in an error siutation anyway.+           ; return False+        }       where         (_, kv') = tidyOpenTyCoVar emptyTidyEnv kv @@ -1630,7 +1789,7 @@     reverse :: forall a. [a] -> [a] So we know that the argument `f xs` must be a "list of something". But what is the "something"? We don't know until we explore the `f xs` a bit more. So we set-out what we do know at the call of `reverse` by instantiate its type with a fresh+out what we do know at the call of `reverse` by instantiating its type with a fresh meta tyvar, `alpha` say. So now the type of the argument `f xs`, and of the result, is `[alpha]`. The unification variable `alpha` stands for the as-yet-unknown type of the elements of the list.@@ -1744,22 +1903,6 @@  -} --- | @tcGetGlobalTyCoVars@ returns a fully-zonked set of *scoped* tyvars free in--- the environment. To improve subsequent calls to the same function it writes--- the zonked set back into the environment. Note that this returns all--- variables free in anything (term-level or type-level) in scope. We thus--- don't have to worry about clashes with things that are not in scope, because--- if they are reachable, then they'll be returned here.--- NB: This is closed over kinds, so it can return unification variables mentioned--- in the kinds of in-scope tyvars.-tcGetGlobalTyCoVars :: TcM TcTyVarSet-tcGetGlobalTyCoVars-  = do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv-       ; gbl_tvs  <- readMutVar gtv_var-       ; gbl_tvs' <- zonkTyCoVarsAndFV gbl_tvs-       ; writeMutVar gtv_var gbl_tvs'-       ; return gbl_tvs' }- zonkTcTypeAndFV :: TcType -> TcM DTyCoVarSet -- Zonk a type and take its free variables -- With kind polymorphism it can be essential to zonk *first*@@ -1788,6 +1931,10 @@   -- the ordering by turning it into a nondeterministic set and the order   -- of zonking doesn't matter for determinism. +zonkDTyCoVarSetAndFV :: DTyCoVarSet -> TcM DTyCoVarSet+zonkDTyCoVarSetAndFV tycovars+  = mkDVarSet <$> (zonkTyCoVarsAndFVList $ dVarSetElems tycovars)+ -- Takes a list of TyCoVars, zonks them and returns a -- deterministically ordered list of their free variables. zonkTyCoVarsAndFVList :: [TyCoVar] -> TcM [TyCoVar]@@ -1819,7 +1966,7 @@                                , ic_wanted = wanted                                , ic_info   = info })   = do { skols'  <- mapM zonkTyCoVarKind skols  -- Need to zonk their kinds!-                                                -- as Trac #7230 showed+                                                -- as #7230 showed        ; given'  <- mapM zonkEvVar given        ; info'   <- zonkSkolemInfo info        ; wanted' <- zonkWCRec wanted@@ -1843,13 +1990,10 @@        ; return (WC { wc_simple = simple', wc_impl = implic' }) }  zonkSimples :: Cts -> TcM Cts-zonkSimples cts = do { cts' <- mapBagM zonkCt' cts+zonkSimples cts = do { cts' <- mapBagM zonkCt cts                      ; traceTc "zonkSimples done:" (ppr cts')                      ; return cts' } -zonkCt' :: Ct -> TcM Ct-zonkCt' ct = zonkCt ct- {- Note [zonkCt behaviour] ~~~~~~~~~~~~~~~~~~~~~~~~~~ zonkCt tries to maintain the canonical form of a Ct.  For example,@@ -1863,7 +2007,7 @@   simple wanted and plugin loop, looks for @CDictCan@s. If a plugin is in use,   constraints are zonked before being passed to the plugin. This means if we   don't preserve a canonical form, @expandSuperClasses@ fails to expand-  superclasses. This is what happened in Trac #11525.+  superclasses. This is what happened in #11525.  - For CHoleCan, once we forget that it's a hole, we can never recover that info. @@ -1888,15 +2032,12 @@        ; args' <- mapM zonkTcType args        ; return $ ct { cc_ev = ev', cc_tyargs = args' } } -zonkCt ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv, cc_rhs = rhs })-  = do { ev'    <- zonkCtEvidence ev-       ; tv_ty' <- zonkTcTyVar tv-       ; case getTyVar_maybe tv_ty' of-           Just tv' -> do { rhs' <- zonkTcType rhs-                          ; return ct { cc_ev    = ev'-                                      , cc_tyvar = tv'-                                      , cc_rhs   = rhs' } }-           Nothing  -> return (mkNonCanonical ev') }+zonkCt (CTyEqCan { cc_ev = ev })+  = mkNonCanonical <$> zonkCtEvidence ev+  -- CTyEqCan has some delicate invariants that may be violated by+  -- zonking (documented with the Ct type) , so we don't want to create+  -- a CTyEqCan here. Besides, this will be canonicalized again anyway,+  -- so there is very little benefit in keeping the CTyEqCan constructor.  zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_insol flag   = do { ev' <- zonkCtEvidence ev@@ -1957,12 +2098,11 @@ -- before all metavars are filled in. zonkTcTypeMapper :: TyCoMapper () TcM zonkTcTypeMapper = TyCoMapper-  { tcm_smart = True-  , tcm_tyvar = const zonkTcTyVar+  { tcm_tyvar = const zonkTcTyVar   , tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv)   , tcm_hole  = hole   , tcm_tycobinder = \_env tv _vis -> ((), ) <$> zonkTyCoVarKind tv-  , tcm_tycon = return }+  , tcm_tycon      = zonkTcTyCon }   where     hole :: () -> CoercionHole -> TcM Coercion     hole _ hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })@@ -1973,6 +2113,15 @@                Nothing -> do { cv' <- zonkCoVar cv                              ; return $ HoleCo (hole { ch_co_var = cv' }) } } +zonkTcTyCon :: TcTyCon -> TcM TcTyCon+-- Only called on TcTyCons+-- A non-poly TcTyCon may have unification+-- variables that need zonking, but poly ones cannot+zonkTcTyCon tc+ | tcTyConIsPoly tc = return tc+ | otherwise        = do { tck' <- zonkTcType (tyConKind tc)+                         ; return (setTcTyConKind tc tck') }+ -- For unbound, mutable tyvars, zonkType uses the function given to it -- For tyvars bound at a for-all, zonkType zonks them to an immutable --      type variable and zonks the kind too@@ -1983,35 +2132,6 @@ zonkCo :: Coercion -> TcM Coercion zonkCo = mapCoercion zonkTcTypeMapper () -zonkTcTyCoVarBndr :: TcTyCoVar -> TcM TcTyCoVar--- A tyvar binder is never a unification variable (TauTv),--- rather it is always a skolem. It *might* be a TyVarTv.--- (Because non-CUSK type declarations use TyVarTvs.)--- Regardless, it may have a kind--- that has not yet been zonked, and may include kind--- unification variables.-zonkTcTyCoVarBndr tyvar-  | isTyVarTyVar tyvar-     -- We want to preserve the binding location of the original TyVarTv.-     -- This is important for error messages. If we don't do this, then-     -- we get bad locations in, e.g., typecheck/should_fail/T2688-  = do { zonked_ty <- zonkTcTyVar tyvar-       ; let zonked_tyvar = tcGetTyVar "zonkTcTyCoVarBndr TyVarTv" zonked_ty-             zonked_name  = getName zonked_tyvar-             reloc'd_name = setNameLoc zonked_name (getSrcSpan tyvar)-       ; return (setTyVarName zonked_tyvar reloc'd_name) }--  | otherwise-  = ASSERT2( isImmutableTyVar tyvar || isCoVar tyvar, pprTyVar tyvar )-    zonkTyCoVarKind tyvar--zonkTyConBinders :: [TyConBinder] -> TcM [TyConBinder]-zonkTyConBinders = mapM zonk1-  where-    zonk1 (Bndr tv vis)-      = do { tv' <- zonkTcTyCoVarBndr tv-           ; return (Bndr tv' vis) }- zonkTcTyVar :: TcTyVar -> TcM TcType -- Simply look through all Flexis zonkTcTyVar tv@@ -2108,10 +2228,10 @@                              Nothing  -> return (env1, Nothing)        ; (env3, orig')  <- zonkTidyOrigin env2 orig        ; return (env3, KindEqOrigin ty1' m_ty2' orig' t_or_k) }-zonkTidyOrigin env (FunDepOrigin1 p1 l1 p2 l2)+zonkTidyOrigin env (FunDepOrigin1 p1 o1 l1 p2 o2 l2)   = do { (env1, p1') <- zonkTidyTcType env  p1        ; (env2, p2') <- zonkTidyTcType env1 p2-       ; return (env2, FunDepOrigin1 p1' l1 p2' l2) }+       ; return (env2, FunDepOrigin1 p1' o1 l1 p2' o2 l2) } zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2)   = do { (env1, p1') <- zonkTidyTcType env  p1        ; (env2, p2') <- zonkTidyTcType env1 p2@@ -2154,7 +2274,7 @@ tidySigSkol :: TidyEnv -> UserTypeCtxt             -> TcType -> [(Name,TcTyVar)] -> SkolemInfo -- We need to take special care when tidying SigSkol--- See Note [SigSkol SkolemInfo] in TcRnTypes+-- See Note [SigSkol SkolemInfo] in Origin tidySigSkol env cx ty tv_prs   = SigSkol cx (tidy_ty env ty) tv_prs'   where@@ -2166,8 +2286,8 @@       where         (env', tv') = tidy_tv_bndr env tv -    tidy_ty env (FunTy arg res)-      = FunTy (tidyType env arg) (tidy_ty env res)+    tidy_ty env ty@(FunTy _ arg res)+      = ty { ft_arg = tidyType env arg, ft_res = tidy_ty env res }      tidy_ty env ty = tidyType env ty @@ -2192,7 +2312,7 @@ -}  -- | According to the rules around representation polymorphism--- (see https://ghc.haskell.org/trac/ghc/wiki/NoSubKinds), no binder+-- (see https://gitlab.haskell.org/ghc/ghc/wikis/no-sub-kinds), no binder -- can have a representation-polymorphic type. This check ensures -- that we respect this rule. It is a bit regrettable that this error -- occurs in zonking, after which we should have reported all errors.
compiler/typecheck/TcMatches.hs view
@@ -12,6 +12,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RecordWildCards #-}  module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda,                    TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker,@@ -21,11 +22,11 @@  import GhcPrelude -import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferSigmaNC, tcInferSigma+import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho                               , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr )  import BasicTypes (LexicalFixity(..))-import HsSyn+import GHC.Hs import TcRnMonad import TcEnv import TcPat@@ -33,6 +34,7 @@ import TcType import TcBinds import TcUnify+import TcOrigin import Name import TysWiredIn import Id@@ -49,7 +51,7 @@ import Control.Monad import Control.Arrow ( second ) -#include "GhclibHsVersions.h"+#include "HsVersions.h"  {- ************************************************************************@@ -72,7 +74,7 @@  tcMatchesFun :: Located Name              -> MatchGroup GhcRn (LHsExpr GhcRn)-             -> ExpRhoType     -- Expected type of function+             -> ExpSigmaType    -- Expected type of function              -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId))                                 -- Returns type of body tcMatchesFun fn@(L _ fun_name) matches exp_ty@@ -219,7 +221,7 @@        ; return (MG { mg_alts = L l matches'                     , mg_ext = MatchGroupTc pat_tys rhs_ty                     , mg_origin = origin }) }-tcMatches _ _ _ (XMatchGroup {}) = panic "tcMatches"+tcMatches _ _ _ (XMatchGroup nec) = noExtCon nec  ------------- tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body@@ -236,10 +238,10 @@       = add_match_ctxt match $         do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $                                 tcGRHSs ctxt grhss rhs_ty-           ; return (Match { m_ext = noExt+           ; return (Match { m_ext = noExtField                            , m_ctxt = mc_what ctxt, m_pats = pats'                            , m_grhss = grhss' }) }-    tc_match  _ _ _ (XMatch _) = panic "tcMatch"+    tc_match  _ _ _ (XMatch nec) = noExtCon nec          -- For (\x -> e), tcExpr has already said "In the expression \x->e"         -- so we don't want to add "In the lambda abstraction \x->e"@@ -263,8 +265,8 @@             <- tcLocalBinds binds $                mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss -        ; return (GRHSs noExt grhss' (L l binds')) }-tcGRHSs _ (XGRHSs _) _ = panic "tcGRHSs"+        ; return (GRHSs noExtField grhss' (L l binds')) }+tcGRHSs _ (XGRHSs nec) _ = noExtCon nec  ------------- tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn))@@ -274,10 +276,10 @@   = do  { (guards', rhs')             <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $                mc_body ctxt rhs-        ; return (GRHS noExt guards' rhs') }+        ; return (GRHS noExtField guards' rhs') }   where     stmt_ctxt  = PatGuard (mc_what ctxt)-tcGRHS _ _ (XGRHS _) = panic "tcGRHS"+tcGRHS _ _ (XGRHS nec) = noExtCon nec  {- ************************************************************************@@ -404,7 +406,7 @@         ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) }  tcGuardStmt ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside-  = do  { (rhs', rhs_ty) <- tcInferSigmaNC rhs+  = do  { (rhs', rhs_ty) <- tcInferRhoNC rhs                                    -- Stmt has a context already         ; (pat', thing)  <- tcPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)                                     pat (mkCheckExpType rhs_ty) $@@ -467,7 +469,7 @@                       ; (pairs', thing) <- loop pairs                       ; return (ids, pairs', thing) }            ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) }-    loop (XParStmtBlock{}:_) = panic "tcLcStmt"+    loop (XParStmtBlock nec:_) = noExtCon nec  tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts                               , trS_bndrs =  bindersMap@@ -478,7 +480,7 @@              --  passed in to tcStmtsAndThen is never looked at        ; (stmts', (bndr_ids, by'))             <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do-               { by' <- traverse tcInferSigma by+               { by' <- traverse tcInferRho by                ; bndr_ids <- tcLookupLocalIds bndr_names                ; return (bndr_ids, by') } @@ -496,14 +498,14 @@              by_arrow :: Type -> Type     -- Wraps 'ty' to '(a->t) -> ty' if the By is present              by_arrow = case by' of                           Nothing       -> \ty -> ty-                          Just (_,e_ty) -> \ty -> (alphaTy `mkFunTy` e_ty) `mkFunTy` ty+                          Just (_,e_ty) -> \ty -> (alphaTy `mkVisFunTy` e_ty) `mkVisFunTy` ty               tup_ty        = mkBigCoreVarTupTy bndr_ids              poly_arg_ty   = m_app alphaTy              poly_res_ty   = m_app (n_app alphaTy)              using_poly_ty = mkInvForAllTy alphaTyVar $                              by_arrow $-                             poly_arg_ty `mkFunTy` poly_res_ty+                             poly_arg_ty `mkVisFunTy` poly_res_ty         ; using' <- tcPolyExpr using using_poly_ty        ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'@@ -516,7 +518,7 @@               -- Ensure that every old binder of type `b` is linked up with its              -- new binder which should have type `n b`-             -- See Note [GroupStmt binder map] in HsExpr+             -- See Note [GroupStmt binder map] in GHC.Hs.Expr              n_bndr_ids  = zipWith mk_n_bndr n_bndr_names bndr_ids              bindersMap' = bndr_ids `zip` n_bndr_ids @@ -616,23 +618,22 @@                          , trS_by = by, trS_using = using, trS_form = form                          , trS_ret = return_op, trS_bind = bind_op                          , trS_fmap = fmap_op }) res_ty thing_inside-  = do { let star_star_kind = liftedTypeKind `mkFunTy` liftedTypeKind-       ; m1_ty   <- newFlexiTyVarTy star_star_kind-       ; m2_ty   <- newFlexiTyVarTy star_star_kind+  = do { m1_ty   <- newFlexiTyVarTy typeToTypeKind+       ; m2_ty   <- newFlexiTyVarTy typeToTypeKind        ; tup_ty  <- newFlexiTyVarTy liftedTypeKind        ; by_e_ty <- newFlexiTyVarTy liftedTypeKind  -- The type of the 'by' expression (if any)           -- n_app :: Type -> Type   -- Wraps a 'ty' into '(n ty)' for GroupForm        ; n_app <- case form of                     ThenForm -> return (\ty -> ty)-                    _        -> do { n_ty <- newFlexiTyVarTy star_star_kind+                    _        -> do { n_ty <- newFlexiTyVarTy typeToTypeKind                                    ; return (n_ty `mkAppTy`) }        ; let by_arrow :: Type -> Type              -- (by_arrow res) produces ((alpha->e_ty) -> res)     ('by' present)              --                          or res                    ('by' absent)              by_arrow = case by of                           Nothing -> \res -> res-                          Just {} -> \res -> (alphaTy `mkFunTy` by_e_ty) `mkFunTy` res+                          Just {} -> \res -> (alphaTy `mkVisFunTy` by_e_ty) `mkVisFunTy` res               poly_arg_ty  = m1_ty `mkAppTy` alphaTy              using_arg_ty = m1_ty `mkAppTy` tup_ty@@ -640,7 +641,7 @@              using_res_ty = m2_ty `mkAppTy` n_app tup_ty              using_poly_ty = mkInvForAllTy alphaTyVar $                              by_arrow $-                             poly_arg_ty `mkFunTy` poly_res_ty+                             poly_arg_ty `mkVisFunTy` poly_res_ty               -- 'stmts' returns a result of type (m1_ty tuple_ty),              -- typically something like [(Int,Bool,Int)]@@ -671,7 +672,7 @@        ; new_res_ty <- newFlexiTyVarTy liftedTypeKind        ; (_, bind_op')  <- tcSyntaxOp MCompOrigin bind_op                              [ synKnownType using_res_ty-                             , synKnownType (n_app tup_ty `mkFunTy` new_res_ty) ]+                             , synKnownType (n_app tup_ty `mkVisFunTy` new_res_ty) ]                              res_ty $ \ _ -> return ()         --------------- Typecheck the 'fmap' function -------------@@ -680,9 +681,9 @@                        _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $                             mkInvForAllTy alphaTyVar $                             mkInvForAllTy betaTyVar  $-                            (alphaTy `mkFunTy` betaTy)-                            `mkFunTy` (n_app alphaTy)-                            `mkFunTy` (n_app betaTy)+                            (alphaTy `mkVisFunTy` betaTy)+                            `mkVisFunTy` (n_app alphaTy)+                            `mkVisFunTy` (n_app betaTy)         --------------- Typecheck the 'using' function -------------        -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c))@@ -696,7 +697,7 @@               -- Ensure that every old binder of type `b` is linked up with its              -- new binder which should have type `n b`-             -- See Note [GroupStmt binder map] in HsExpr+             -- See Note [GroupStmt binder map] in GHC.Hs.Expr              n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids              bindersMap' = bndr_ids `zip` n_bndr_ids @@ -741,14 +742,13 @@ --        -> m (st1, (st2, st3)) -- tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside-  = do { let star_star_kind = liftedTypeKind `mkFunTy` liftedTypeKind-       ; m_ty   <- newFlexiTyVarTy star_star_kind+  = do { m_ty   <- newFlexiTyVarTy typeToTypeKind         ; let mzip_ty  = mkInvForAllTys [alphaTyVar, betaTyVar] $                         (m_ty `mkAppTy` alphaTy)-                        `mkFunTy`+                        `mkVisFunTy`                         (m_ty `mkAppTy` betaTy)-                        `mkFunTy`+                        `mkVisFunTy`                         (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])        ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty @@ -820,7 +820,7 @@   = do  {       -- Deal with rebindable syntax:                 --       (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty                 -- This level of generality is needed for using do-notation-                -- in full generality; see Trac #1537+                -- in full generality; see #1537            ((rhs', pat', new_res_ty, thing), bind_op')             <- tcSyntaxOp DoOrigin bind_op [SynRho, SynFun SynAny SynRho] res_ty $@@ -884,7 +884,7 @@         ; ((_, mfix_op'), mfix_res_ty)             <- tcInferInst $ \ exp_ty ->                tcSyntaxOp DoOrigin mfix_op-                          [synKnownType (mkFunTy tup_ty stmts_ty)] exp_ty $+                          [synKnownType (mkVisFunTy tup_ty stmts_ty)] exp_ty $                \ _ -> return ()          ; ((thing, new_res_ty), bind_op')@@ -949,7 +949,7 @@ pushing info from the context into the RHS.  To do this, we check the rebindable syntax first, and push that information into (tcMonoExprNC rhs). Otherwise the error shows up when checking the rebindable syntax, and-the expected/inferred stuff is back to front (see Trac #3613).+the expected/inferred stuff is back to front (see #3613).  Note [typechecking ApplicativeStmt] @@ -982,7 +982,7 @@       ; ts <- replicateM (arity-1) $ newInferExpTypeInst       ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind       ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind-      ; let fun_ty = mkFunTys pat_tys body_ty+      ; let fun_ty = mkVisFunTys pat_tys body_ty         -- NB. do the <$>,<*> operators first, we don't want type errors here        --     i.e. goOps before goArgs@@ -992,7 +992,7 @@        -- Typecheck each ApplicativeArg separately       -- See Note [ApplicativeDo and constraints]-      ; args' <- mapM goArg (zip3 args pat_tys exp_tys)+      ; args' <- mapM (goArg body_ty) (zip3 args pat_tys exp_tys)        -- Bring into scope all the things bound by the args,       -- and typecheck the thing_inside@@ -1012,18 +1012,30 @@            ; ops' <- goOps t_i ops            ; return (op' : ops') } -    goArg :: (ApplicativeArg GhcRn, Type, Type)+    goArg :: Type -> (ApplicativeArg GhcRn, Type, Type)           -> TcM (ApplicativeArg GhcTcId) -    goArg (ApplicativeArgOne x pat rhs isBody, pat_ty, exp_ty)+    goArg body_ty (ApplicativeArgOne+                    { app_arg_pattern = pat+                    , arg_expr        = rhs+                    , fail_operator   = fail_op+                    , ..+                    }, pat_ty, exp_ty)       = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $         addErrCtxt (pprStmtInCtxt ctxt (mkBindStmt pat rhs))   $         do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty)            ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $                           return ()-           ; return (ApplicativeArgOne x pat' rhs' isBody) }+           ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op body_ty -    goArg (ApplicativeArgMany x stmts ret pat, pat_ty, exp_ty)+           ; return (ApplicativeArgOne+                      { app_arg_pattern = pat'+                      , arg_expr        = rhs'+                      , fail_operator   = fail_op'+                      , .. }+                    ) }++    goArg _body_ty (ApplicativeArgMany x stmts ret pat, pat_ty, exp_ty)       = do { (stmts', (ret',pat')) <-                 tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $                 \res_ty  -> do@@ -1034,19 +1046,18 @@                   }            ; return (ApplicativeArgMany x stmts' ret' pat') } -    goArg (XApplicativeArg _, _, _) = panic "tcApplicativeStmts"+    goArg _body_ty (XApplicativeArg nec, _, _) = noExtCon nec      get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id]-    get_arg_bndrs (ApplicativeArgOne _ pat _ _)  = collectPatBinders pat-    get_arg_bndrs (ApplicativeArgMany _ _ _ pat) = collectPatBinders pat-    get_arg_bndrs (XApplicativeArg _)            = panic "tcApplicativeStmts"-+    get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat+    get_arg_bndrs (ApplicativeArgMany { bv_pattern =  pat }) = collectPatBinders pat+    get_arg_bndrs (XApplicativeArg nec)          = noExtCon nec  {- Note [ApplicativeDo and constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ An applicative-do is supposed to take place in parallel, so constraints bound in one arm can't possibly be available in another-(Trac #13242).  Our current rule is this (more details and discussion+(#13242).  Our current rule is this (more details and discussion on the ticket). Consider     ...stmts...@@ -1096,5 +1107,5 @@      args_in_match :: LMatch GhcRn body -> Int     args_in_match (L _ (Match { m_pats = pats })) = length pats-    args_in_match (L _ (XMatch _)) = panic "checkArgs"-checkArgs _ (XMatchGroup{}) = panic "checkArgs"+    args_in_match (L _ (XMatch nec)) = noExtCon nec+checkArgs _ (XMatchGroup nec) = noExtCon nec
compiler/typecheck/TcMatches.hs-boot view
@@ -1,11 +1,11 @@ module TcMatches where-import HsSyn    ( GRHSs, MatchGroup, LHsExpr )+import GHC.Hs   ( GRHSs, MatchGroup, LHsExpr ) import TcEvidence( HsWrapper ) import Name     ( Name )-import TcType   ( ExpRhoType, TcRhoType )+import TcType   ( ExpSigmaType, TcRhoType ) import TcRnTypes( TcM ) import SrcLoc   ( Located )-import HsExtension ( GhcRn, GhcTcId )+import GHC.Hs.Extension ( GhcRn, GhcTcId )  tcGRHSsPat    :: GRHSs GhcRn (LHsExpr GhcRn)               -> TcRhoType@@ -13,5 +13,5 @@  tcMatchesFun :: Located Name              -> MatchGroup GhcRn (LHsExpr GhcRn)-             -> ExpRhoType+             -> ExpSigmaType              -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId))
compiler/typecheck/TcPat.hs view
@@ -15,13 +15,13 @@              , tcPat, tcPat_O, tcPats              , addDataConStupidTheta, badFieldCon, polyPatSig ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcSyntaxOpGen, tcInferSigma ) -import HsSyn+import GHC.Hs import TcHsSyn import TcSigs( TcPragEnv, lookupPragEnv, addInlinePrags ) import TcRnMonad@@ -33,12 +33,13 @@ import TcEnv import TcMType import TcValidity( arityErr )-import Type ( pprTyVars )+import TyCoPpr ( pprTyVars ) import TcType import TcUnify import TcHsType import TysWiredIn import TcEvidence+import TcOrigin import TyCon import DataCon import PatSyn@@ -446,6 +447,8 @@ tc_pat penv (TuplePat _ pats boxity) pat_ty thing_inside   = do  { let arity = length pats               tc = tupleTyCon boxity arity+              -- NB: tupleTyCon does not flatten 1-tuples+              -- See Note [Don't flatten tuples from HsSyn] in MkCore         ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)                                                penv pat_ty                      -- Unboxed tuples have RuntimeRep vars, which we discard:@@ -466,7 +469,7 @@                                  -- pat_ty /= pat_ty iff coi /= IdCo               possibly_mangled_result                 | gopt Opt_IrrefutableTuples dflags &&-                  isBoxed boxity      = LazyPat noExt (noLoc unmangled_result)+                  isBoxed boxity      = LazyPat noExtField (noLoc unmangled_result)                 | otherwise           = unmangled_result          ; pat_ty <- readExpType pat_ty@@ -743,7 +746,7 @@         ; checkExistentials ex_tvs all_arg_tys penv          ; tenv <- instTyVarsWith PatOrigin univ_tvs ctxt_res_tys-                  -- NB: Do not use zipTvSubst!  See Trac #14154+                  -- NB: Do not use zipTvSubst!  See #14154                   -- We want to create a well-kinded substitution, so                   -- that the instantiated type is well-kinded @@ -784,7 +787,7 @@         { let theta'     = substTheta tenv (eqSpecPreds eq_spec ++ theta)                            -- order is *important* as we generate the list of                            -- dictionary binders from theta'-              no_equalities = not (any isNomEqPred theta')+              no_equalities = null eq_spec && not (any isEqPred theta)               skol_info = PatSkol (RealDataCon data_con) mc               mc = case pe_ctxt penv of                      LamPat mc -> mc@@ -795,7 +798,7 @@         ; checkTc (no_equalities || gadts_on || families_on)                   (text "A pattern match on a GADT requires the" <+>                    text "GADTs or TypeFamilies language extension")-                  -- Trac #2905 decided that a *pattern-match* of a GADT+                  -- #2905 decided that a *pattern-match* of a GADT                   -- should require the GADT language flag.                   -- Re TypeFamilies see also #7156 @@ -1006,7 +1009,7 @@                  -- No matching field; chances are this field label comes from some                 -- other record type (or maybe none).  If this happens, just fail,-                -- otherwise we get crashes later (Trac #8570), and similar:+                -- otherwise we get crashes later (#8570), and similar:                 --      f (R { foo = (a,b) }) = a+b                 -- If foo isn't one of R's fields, we don't want to crash when                 -- typechecking the "a+b".
compiler/typecheck/TcPatSyn.hs view
@@ -16,7 +16,7 @@  import GhcPrelude -import HsSyn+import GHC.Hs import TcPat import Type( tidyTyCoVarBinders, tidyTypes, tidyType ) import TcRnMonad@@ -40,10 +40,11 @@ import BasicTypes import TcSimplify import TcUnify-import Type( PredTree(..), EqRel(..), classifyPredType )+import Predicate import TysWiredIn import TcType import TcEvidence+import TcOrigin import BuildTyCl import VarSet import MkId@@ -57,7 +58,7 @@ import Control.Monad ( zipWithM ) import Data.List( partition ) -#include "GhclibHsVersions.h"+#include "HsVersions.h"  {- ************************************************************************@@ -102,7 +103,7 @@          matcher_id = mkLocalId matcher_name $                       mkSpecForAllTys [alphaTyVar] alphaTy -recoverPSB (XPatSynBind {}) = panic "recoverPSB"+recoverPSB (XPatSynBind nec) = noExtCon nec  {- Note [Pattern synonym error recovery] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -110,14 +111,14 @@ the rest of tc_patsyn_finish, because we may get knock-on errors, or even a crash.  E.g. from    pattern What = True :: Maybe-we get a kind error; and we must stop right away (Trac #15289).+we get a kind error; and we must stop right away (#15289).  We stop if there are /any/ unsolved constraints, not just insoluble ones; because pattern synonyms are top-level things, we will never solve them later if we can't solve them now.  And if we were to carry on, tc_patsyn_finish does zonkTcTypeToType, which defaults any unsolved unificatdion variables to Any, which confuses the error-reporting no end (Trac #15685).+reporting no end (#15685).  So we use simplifyTop to completely solve the constraint, report any errors, throw an exception.@@ -151,7 +152,7 @@              named_taus = (name, pat_ty) : map mk_named_tau args              mk_named_tau arg                = (getName arg, mkSpecForAllTys ex_tvs (varType arg))-               -- The mkSpecForAllTys is important (Trac #14552), albeit+               -- The mkSpecForAllTys is important (#14552), albeit                -- slightly artifical (there is no variable with this funny type).                -- We do not want to quantify over variable (alpha::k)                -- that mention the existentially-bound type variables@@ -187,7 +188,7 @@                             , mkTyVarTys ex_tvs, prov_theta, prov_evs)                           (map nlHsVar args, map idType args)                           pat_ty rec_fields } }-tcInferPatSynDecl (XPatSynBind _) = panic "tcInferPatSynDecl"+tcInferPatSynDecl (XPatSynBind nec) = noExtCon nec  mkProvEvidence :: EvId -> Maybe (PredType, EvTerm) -- See Note [Equality evidence in pattern synonyms]@@ -246,7 +247,7 @@ pattern (AST a), nor is it existentially bound.  It's really only fixed by the type of the continuation. -Trac #14552 showed that this can go wrong if the kind of 's' mentions+#14552 showed that this can go wrong if the kind of 's' mentions existentially bound variables.  We obviously can't make a type like   $mP :: forall (s::k->*) a. Prj s => AST a -> (forall k. s a -> r)                                    -> r -> r@@ -270,7 +271,7 @@ (NB: technically the (k1~k2) existential dictionary is not necessary, but it's there at the moment.) -Now consider (Trac #14394):+Now consider (#14394):    pattern Foo = HRefl in a non-poly-kinded module.  We don't want to get     pattern Foo :: () => (* ~ *, b ~ a) => a :~~: b@@ -300,7 +301,7 @@   $bP :: forall a b. (a ~# Maybe b, Eq b) => [b] -> X a  and that is bad because (a ~# Maybe b) is not a predicate type-(see Note [Types for coercions, predicates, and evidence] in Type)+(see Note [Types for coercions, predicates, and evidence] in TyCoRep and is not implicitly instantiated.  So in mkProvEvidence we lift (a ~# b) to (a ~ b).  Tiresome, and@@ -310,7 +311,7 @@  Note [Coercions that escape] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Trac #14507 showed an example where the inferred type of the matcher+#14507 showed an example where the inferred type of the matcher for the pattern synonym was somethign like    $mSO :: forall (r :: TYPE rep) kk (a :: k).            TypeRep k a@@ -384,9 +385,6 @@            ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )            pushLevelAndCaptureConstraints            $            tcExtendTyVarEnv univ_tvs                 $-           tcExtendKindEnvList [(getName (binderVar ex_tv), APromotionErr PatSynExPE)-                               | ex_tv <- extra_ex] $-               -- See Note [Pattern synonym existentials do not scope]            tcPat PatSyn lpat (mkCheckExpType pat_ty) $            do { let in_scope    = mkInScopeSet (mkVarSet univ_tvs)                     empty_subst = mkEmptyTCvSubst in_scope@@ -400,7 +398,7 @@                   -- satisfy the substitution invariant. There's no need to                   -- add 'ex_tvs' as they are already in the domain of the                   -- substitution.-                  -- See also Note [The substitution invariant] in TyCoRep.+                  -- See also Note [The substitution invariant] in TyCoSubst.               ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta'               ; args'      <- zipWithM (tc_arg subst) arg_names arg_tys               ; return (ex_tvs', prov_dicts, args') }@@ -408,11 +406,11 @@        ; let skol_info = SigSkol (PatSynCtxt name) pat_ty []                          -- The type here is a bit bogus, but we do not print                          -- the type for PatSynCtxt, so it doesn't matter-                         -- See TcRnTypes Note [Skolem info for pattern synonyms]+                         -- See Note [Skolem info for pattern synonyms] in Origin        ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted         -- Solve the constraints now, because we are about to make a PatSyn,-       -- which should not contain unification variables and the like (Trac #10997)+       -- which should not contain unification variables and the like (#10997)        ; simplifyTopImplic implics         -- ToDo: in the bidirectional case, check that the ex_tvs' are all distinct@@ -437,7 +435,7 @@                 -- Why do we need tcSubType here?                 -- See Note [Pattern synonyms and higher rank types]            ; return (mkLHsWrap wrap $ nlHsVar arg_id) }-tcCheckPatSynDecl (XPatSynBind _) _ = panic "tcCheckPatSynDecl"+tcCheckPatSynDecl (XPatSynBind nec) _ = noExtCon nec  {- [Pattern synonyms and higher rank types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -449,55 +447,7 @@  This should work.  But in the matcher we must match against MkT, and then instantiate its argument 'x', to get a function of type (Int -> Int).-Equality is not enough!  Trac #13752 was an example.--Note [Pattern synonym existentials do not scope]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (Trac #14498):-  pattern SS :: forall (t :: k). () =>-                => forall (a :: kk -> k) (n :: kk).-                => TypeRep n -> TypeRep t-  pattern SS n <- (App (Typeable :: TypeRep (a::kk -> k)) n)--Here 'k' is implicitly bound in the signature, but (with--XScopedTypeVariables) it does still scope over the pattern-synonym-definition.  But what about 'kk', which is oexistential?  It too is-implicitly bound in the signature; should it too scope?  And if so,-what type variable is it bound to?--The trouble is that the type variable to which it is bound is itself-only brought into scope in part the pattern, so it makes no sense for-'kk' to scope over the whole pattern.  See the discussion on-Trac #14498, esp comment:16ff. Here is a simpler example:-  data T where { MkT :: x -> (x->Int) -> T }-  pattern P :: () => forall x. x -> (x->Int) -> T-  pattern P a b = (MkT a b, True)--Here it would make no sense to mention 'x' in the True pattern,-like this:-  pattern P a b = (MkT a b, True :: x)--The 'x' only makes sense "under" the MkT pattern. Conclusion: the-existential type variables of a pattern-synonym signature should not-scope.--But it's not that easy to implement, because we don't know-exactly what the existentials /are/ until we get to type checking.-(See Note [The pattern-synonym signature splitting rule], and-the partition of implicit_tvs in tcCheckPatSynDecl.)--So we do this:--- The reaner brings all the implicitly-bound kind variables into-  scope, without trying to distinguish universal from existential--- tcCheckPatSynDecl uses tcExtendKindEnvList to bind the-  implicitly-bound existentials to-      APromotionErr PatSynExPE-  It's not really a promotion error, but it's a way to bind the Name-  (which the renamer has not complained about) to something that, when-  looked up, will cause a complaint (in this case-  TcHsType.promotionErr)+Equality is not enough!  #13752 was an example.   Note [The pattern-synonym signature splitting rule]@@ -506,7 +456,7 @@      the kind-generalised variables, and      the implicitly-bound variables into universal and existential.  The rule is this-(see discussion on Trac #11224):+(see discussion on #11224):       The universal tyvars are the ones mentioned in           - univ_tvs: the user-specified (forall'd) universals@@ -527,7 +477,7 @@  This is an odd example because Q has only one syntactic argument, and so presumably is defined by a view pattern matching a function.  But-it can happen (Trac #11977, #12108).+it can happen (#11977, #12108).  We don't know Q's arity from the pattern signature, so we have to wait until we see the pattern declaration itself before deciding res_ty is,@@ -600,7 +550,7 @@   TauTvs) in tcCheckPatSynDecl.  But (a) strengthening the check here   is redundant since tcPatSynBuilderBind does the job, (b) it was   still incomplete (TyVarTvs can unify with each other), and (c) it-  didn't even work (Trac #13441 was accepted with+  didn't even work (#13441 was accepted with   ExplicitBidirectional, but rejected if expressed in   ImplicitBidirectional form.  Conclusion: trying to be too clever is   a bad idea.@@ -750,16 +700,16 @@                | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy])                | otherwise   = (args,                 arg_tys)              cont_ty = mkInfSigmaTy ex_tvs prov_theta $-                       mkFunTys cont_arg_tys res_ty+                       mkVisFunTys cont_arg_tys res_ty -             fail_ty  = mkFunTy voidPrimTy res_ty+             fail_ty  = mkVisFunTy voidPrimTy res_ty         ; matcher_name <- newImplicitBinder name mkMatcherOcc        ; scrutinee    <- newSysLocalId (fsLit "scrut") pat_ty        ; cont         <- newSysLocalId (fsLit "cont")  cont_ty        ; fail         <- newSysLocalId (fsLit "fail")  fail_ty -       ; let matcher_tau   = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty+       ; let matcher_tau   = mkVisFunTys [pat_ty, cont_ty, fail_ty] res_ty              matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau              matcher_id    = mkExportedVanillaId matcher_name matcher_sigma                              -- See Note [Exported LocalIds] in Id@@ -777,13 +727,13 @@                            mkHsCaseAlt lwpat fail']              body = mkLHsWrap (mkWpLet req_ev_binds) $                     cL (getLoc lpat) $-                    HsCase noExt (nlHsVar scrutinee) $+                    HsCase noExtField (nlHsVar scrutinee) $                     MG{ mg_alts = cL (getLoc lpat) cases                       , mg_ext = MatchGroupTc [pat_ty] res_ty                       , mg_origin = Generated                       }              body' = noLoc $-                     HsLam noExt $+                     HsLam noExtField $                      MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr                                                         args body]                        , mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty@@ -792,7 +742,7 @@              match = mkMatch (mkPrefixFunRhs (cL loc name)) []                              (mkHsLams (rr_tv:res_tv:univ_tvs)                                        req_dicts body')-                             (noLoc (EmptyLocalBinds noExt))+                             (noLoc (EmptyLocalBinds noExtField))              mg :: MatchGroup GhcTc (LHsExpr GhcTc)              mg = MG{ mg_alts = cL (getLoc match) [match]                     , mg_ext = MatchGroupTc [] res_ty@@ -848,8 +798,8 @@              builder_sigma  = add_void need_dummy_arg $                               mkForAllTys univ_bndrs $                               mkForAllTys ex_bndrs $-                              mkFunTys theta $-                              mkFunTys arg_tys $+                              mkPhiTy theta $+                              mkVisFunTys arg_tys $                               pat_ty              builder_id     = mkExportedVanillaId builder_name builder_sigma               -- See Note [Exported LocalIds] in Id@@ -914,11 +864,11 @@     mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)     mk_mg body = mkMatchGroup Generated [builder_match]           where-            builder_args  = [cL loc (VarPat noExt (cL loc n))+            builder_args  = [cL loc (VarPat noExtField (cL loc n))                             | (dL->L loc n) <- args]             builder_match = mkMatch (mkPrefixFunRhs (cL loc name))                                     builder_args body-                                    (noLoc (EmptyLocalBinds noExt))+                                    (noLoc (EmptyLocalBinds noExtField))      args = case details of               PrefixCon args     -> args@@ -933,13 +883,13 @@       = mg { mg_alts = cL l [cL loc (match { m_pats = nlWildPatName : pats })] }     add_dummy_arg other_mg = pprPanic "add_dummy_arg" $                              pprMatches other_mg-tcPatSynBuilderBind (XPatSynBind _) = panic "tcPatSynBuilderBind"+tcPatSynBuilderBind (XPatSynBind nec) = noExtCon nec  tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType) -- monadic only for failure tcPatSynBuilderOcc ps   | Just (builder_id, add_void_arg) <- builder-  , let builder_expr = HsConLikeOut noExt (PatSynCon ps)+  , let builder_expr = HsConLikeOut noExtField (PatSynCon ps)         builder_ty   = idType builder_id   = return $     if add_void_arg@@ -956,7 +906,7 @@  add_void :: Bool -> Type -> Type add_void need_dummy_arg ty-  | need_dummy_arg = mkFunTy voidPrimTy ty+  | need_dummy_arg = mkVisFunTy voidPrimTy ty   | otherwise      = ty  tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn@@ -978,14 +928,14 @@                     -> Either MsgDoc (HsExpr GhcRn)     mkPrefixConExpr lcon@(dL->L loc _) pats       = do { exprs <- mapM go pats-           ; return (foldl' (\x y -> HsApp noExt (cL loc x) y)-                            (HsVar noExt lcon) exprs) }+           ; return (foldl' (\x y -> HsApp noExtField (cL loc x) y)+                            (HsVar noExtField lcon) exprs) }      mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn)                     -> Either MsgDoc (HsExpr GhcRn)     mkRecordConExpr con fields       = do { exprFields <- mapM go fields-           ; return (RecordCon noExt con exprFields) }+           ; return (RecordCon noExtField con exprFields) }      go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn)     go (dL->L loc p) = cL loc <$> go1 p@@ -1002,27 +952,27 @@      go1 (VarPat _ (dL->L l var))         | var `elemNameSet` lhsVars-        = return $ HsVar noExt (cL l var)+        = return $ HsVar noExtField (cL l var)         | otherwise         = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")-    go1 (ParPat _ pat)          = fmap (HsPar noExt) $ go pat+    go1 (ParPat _ pat)          = fmap (HsPar noExtField) $ go pat     go1 p@(ListPat reb pats)       | Nothing <- reb = do { exprs <- mapM go pats-                            ; return $ ExplicitList noExt Nothing exprs }+                            ; return $ ExplicitList noExtField Nothing exprs }       | otherwise                   = notInvertibleListPat p     go1 (TuplePat _ pats box)       = do { exprs <- mapM go pats-                                         ; return $ ExplicitTuple noExt-                                           (map (noLoc . (Present noExt)) exprs)+                                         ; return $ ExplicitTuple noExtField+                                           (map (noLoc . (Present noExtField)) exprs)                                                                            box }     go1 (SumPat _ pat alt arity)    = do { expr <- go1 (unLoc pat)-                                         ; return $ ExplicitSum noExt alt arity+                                         ; return $ ExplicitSum noExtField alt arity                                                                    (noLoc expr)                                          }-    go1 (LitPat _ lit)              = return $ HsLit noExt lit+    go1 (LitPat _ lit)              = return $ HsLit noExtField lit     go1 (NPat _ (dL->L _ n) mb_neg _)         | Just neg <- mb_neg        = return $ unLoc $ nlHsSyntaxApps neg-                                                     [noLoc (HsOverLit noExt n)]-        | otherwise                 = return $ HsOverLit noExt n+                                                     [noLoc (HsOverLit noExtField n)]+        | otherwise                 = return $ HsOverLit noExtField n     go1 (ConPatOut{})               = panic "ConPatOut in output of renamer"     go1 (CoPat{})                   = panic "CoPat in output of renamer"     go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))@@ -1058,12 +1008,12 @@      -- We should really be able to invert list patterns, even when     -- rebindable syntax is on, but doing so involves a bit of-    -- refactoring; see Trac #14380.  Until then we reject with a+    -- refactoring; see #14380.  Until then we reject with a     -- helpful error message.     notInvertibleListPat p       = Left (vcat [ not_invertible_msg p                    , text "Reason: rebindable syntax is on."-                   , text "This is fixable: add use-case to Trac #14380" ])+                   , text "This is fixable: add use-case to #14380" ])  {- Note [Builder for a bidirectional pattern synonym] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1132,7 +1082,7 @@   $buildL x = Left x :: Either [a] [b] because that wil either mean (forall a b. Either [a] [b]), or we'll get a complaint that 'a' and 'b' are out of scope. (Actually the-latter; Trac #9867.)  No, the job of the signature is done, so when+latter; #9867.)  No, the job of the signature is done, so when converting the pattern to an expression (for the builder RHS) we simply discard the signature.
compiler/typecheck/TcPatSyn.hs-boot view
@@ -1,10 +1,10 @@ module TcPatSyn where -import HsSyn     ( PatSynBind, LHsBinds )+import GHC.Hs    ( PatSynBind, LHsBinds ) import TcRnTypes ( TcM, TcSigInfo ) import TcRnMonad ( TcGblEnv) import Outputable ( Outputable )-import HsExtension ( GhcRn, GhcTc )+import GHC.Hs.Extension ( GhcRn, GhcTc ) import Data.Maybe  ( Maybe )  tcPatSynDecl :: PatSynBind GhcRn GhcRn
compiler/typecheck/TcPluginM.hs view
@@ -3,7 +3,6 @@ -- access select functions of the 'TcM', principally those to do with -- reading parts of the state. module TcPluginM (-#if defined(GHCI)         -- * Basic TcPluginM functionality         TcPluginM,         tcPluginIO,@@ -49,10 +48,8 @@         newEvVar,         setEvBind,         getEvBindsTcPluginM-#endif     ) where -#if defined(GHCI) import GhcPrelude  import qualified TcRnMonad as TcM@@ -64,14 +61,14 @@ import qualified Finder  import FamInstEnv ( FamInstEnv )-import TcRnMonad  ( TcGblEnv, TcLclEnv, Ct, CtLoc, TcPluginM+import TcRnMonad  ( TcGblEnv, TcLclEnv, TcPluginM                   , unsafeTcPluginTcM, getEvBindsTcPluginM                   , liftIO, traceTc )+import Constraint ( Ct, CtLoc, CtEvidence(..), ctLocOrigin ) import TcMType    ( TcTyVar, TcType ) import TcEnv      ( TcTyThing ) import TcEvidence ( TcCoercion, CoercionHole, EvTerm(..)                   , EvExpr, EvBind, mkGivenEvBind )-import TcRnTypes  ( CtEvidence(..) ) import Var        ( EvVar )  import Module@@ -161,7 +158,7 @@ -- | Create a new wanted constraint. newWanted  :: CtLoc -> PredType -> TcPluginM CtEvidence newWanted loc pty-  = unsafeTcPluginTcM (TcM.newWanted (TcM.ctLocOrigin loc) Nothing pty)+  = unsafeTcPluginTcM (TcM.newWanted (ctLocOrigin loc) Nothing pty)  -- | Create a new derived constraint. newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence@@ -190,7 +187,3 @@ setEvBind ev_bind = do     tc_evbinds <- getEvBindsTcPluginM     unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind-#else--- this dummy import is needed as a consequence of NoImplicitPrelude-import GhcPrelude ()-#endif
compiler/typecheck/TcRnDriver.hs view
@@ -4,7 +4,7 @@  \section[TcRnDriver]{Typechecking a whole module} -https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TypeChecker+https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/type-checker -}  {-# LANGUAGE CPP #-}@@ -24,7 +24,7 @@         getModuleInterface,         tcRnDeclsi,         isGHCiMonad,-        runTcInteractive,    -- Used by GHC API clients (Trac #8878)+        runTcInteractive,    -- Used by GHC API clients (#8878)         tcRnLookupName,         tcRnGetInfo,         tcRnModule, tcRnModuleTcRnM,@@ -64,7 +64,7 @@ import TysWiredIn ( unitTy, mkListTy ) import Plugins import DynFlags-import HsSyn+import GHC.Hs import IfaceSyn ( ShowSub(..), showToHeader ) import IfaceType( ShowForAllFlag(..) ) import PatSyn( pprPatSynType )@@ -76,6 +76,8 @@ import TcRnMonad import TcRnExports import TcEvidence+import Constraint+import TcOrigin import qualified BooleanFormula as BF import PprTyThing( pprTyThingInContext ) import CoreFVs( orphNamesOfFamInst )@@ -134,14 +136,17 @@ import Inst (tcGetInsts) import qualified GHC.LanguageExtensions as LangExt import Data.Data ( Data )-import HsDumpAst+import GHC.Hs.Dump import qualified Data.Set as S  import Control.DeepSeq import Control.Monad -#include "GhclibHsVersions.h"+import TcHoleFitTypes ( HoleFitPluginR (..) ) ++#include "HsVersions.h"+ {- ************************************************************************ *                                                                      *@@ -160,11 +165,11 @@ tcRnModule hsc_env mod_sum save_rn_syntax    parsedModule@HsParsedModule {hpm_module= (dL->L loc this_module)}  | RealSrcSpan real_loc <- loc- = withTiming (pure dflags)+ = withTiming dflags               (text "Renamer/typechecker"<+>brackets (ppr this_mod))               (const ()) $    initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $-          withTcPlugins hsc_env $+          withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $            tcRnModuleTcRnM hsc_env mod_sum parsedModule pair @@ -291,7 +296,7 @@                         -- Do this /after/ typeinference, so that when reporting                         -- a function with no type signature we can give the                         -- inferred type-                        reportUnusedNames export_ies tcg_env+                        reportUnusedNames tcg_env                       ; -- add extra source files to tcg_dependent_files                         addDependentFiles src_files                       ; tcg_env <- runTypecheckerPlugin mod_sum hsc_env tcg_env@@ -400,8 +405,8 @@          -- Check for the 'main' declaration         -- Must do this inside the captureTopConstraints+        -- NB: always set envs *before* captureTopConstraints       ; (tcg_env, lie_main) <- setEnvs (tcg_env, tcl_env) $-                               -- always set envs *before* captureTopConstraints                                captureTopConstraints $                                checkMain explicit_mod_hdr @@ -503,10 +508,13 @@     let run_finalizer (lcl_env, f) =             setLclEnv lcl_env (runRemoteModFinalizers f) -    (_, lie_th) <- captureTopConstraints $ mapM_ run_finalizer th_modfinalizers+    (_, lie_th) <- captureTopConstraints $+                   mapM_ run_finalizer th_modfinalizers+       -- Finalizers can add top-level declarations with addTopDecls, so       -- we have to run tc_rn_src_decls to get them     (tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls []+     setEnvs (tcg_env, tcl_env) $ do       -- Subsequent rounds of finalizers run after any new constraints are       -- simplified, or some types might not be complete when using reify@@ -533,7 +541,7 @@         -- Get TH-generated top-level declarations and make sure they don't         -- contain any splices since we don't handle that at the moment         ---        -- The plumbing here is a bit odd: see Trac #10853+        -- The plumbing here is a bit odd: see #10853       ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv       ; th_ds <- readTcRef th_topdecls_var       ; writeTcRef th_topdecls_var []@@ -550,7 +558,7 @@                                 ("Declaration splices are not "                                   ++ "permitted inside top-level "                                   ++ "declarations added with addTopDecls"))-                        ; Just (XSpliceDecl _, _) -> panic "tc_rn_src_decls"+                        ; Just (XSpliceDecl nec, _) -> noExtCon nec                         }                       -- Rename TH-generated top-level declarations                     ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env@@ -593,7 +601,7 @@                 ; return (tcg_env, tcl_env, lie1 `andWC` lie2)                }-          ; Just (XSpliceDecl _, _) -> panic "tc_rn_src_decls"+          ; Just (XSpliceDecl nec, _) -> noExtCon nec           }       } @@ -617,11 +625,12 @@                             , hs_defds  = def_decls                             , hs_ruleds = rule_decls                             , hs_annds  = _-                            , hs_valds-                                 = XValBindsLR (NValBinds val_binds val_sigs) })+                            , hs_valds  = XValBindsLR (NValBinds val_binds val_sigs) })               <- rnTopSrcDecls first_group+         -- The empty list is for extra dependencies coming from .hs-boot files         -- See Note [Extra dependencies from .hs-boot files] in RnSource+         ; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do {               -- NB: setGblEnv **before** captureTopConstraints so that               -- if the latter reports errors, it knows what's in scope@@ -629,8 +638,8 @@                 -- Check for illegal declarations         ; case group_tail of              Just (SpliceDecl _ d _, _) -> badBootDecl hsc_src "splice" d-             Just (XSpliceDecl _, _) -> panic "tcRnHsBootDecls"-             Nothing                  -> return ()+             Just (XSpliceDecl nec, _)  -> noExtCon nec+             Nothing                    -> return ()         ; mapM_ (badBootDecl hsc_src "foreign") for_decls         ; mapM_ (badBootDecl hsc_src "default") def_decls         ; mapM_ (badBootDecl hsc_src "rule")    rule_decls@@ -760,7 +769,7 @@ It is much more directly simply to extract the DFunIds from the md_types of the SelfBootInfo. -See Trac #4003, #16038 for why we need to take care here.+See #4003, #16038 for why we need to take care here. -}  checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo]@@ -851,12 +860,12 @@           --    That ensures that the TyCon etc inside the type are           --    the ones defined in this module, not the ones gotten           --    from the hi-boot file, which may have a lot less info-          --    (Trac #8743, comment:10).+          --    (#8743, comment:10).           --           --  * The DFunIds from boot_details are /GlobalIds/, because           --    they come from typechecking M.hi-boot.           --    But all bindings in this module should be for /LocalIds/,-          --    otherwise dependency analysis fails (Trac #16038). This+          --    otherwise dependency analysis fails (#16038). This           --    is another reason for using mkExportedVanillaId, rather           --    that modifying boot_dfun, to make local_boot_fun. @@ -1453,7 +1462,7 @@                           foe_binds              ; fo_gres = fi_gres `unionBags` foe_gres-            ; fo_fvs = foldrBag (\gre fvs -> fvs `addOneFV` gre_name gre)+            ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` gre_name gre)                                 emptyFVs fo_gres              ; sig_names = mkNameSet (collectHsValBinders hs_val_binds)@@ -1564,7 +1573,7 @@          -- Unqualified import?         isUnqualified :: ImportDecl GhcRn -> Bool-        isUnqualified = not . ideclQualified+        isUnqualified = not . isImportDeclQualified . ideclQualified          -- List of explicitly imported (or hidden) Names from a single import.         --   Nothing -> No explicit imports@@ -1677,7 +1686,7 @@ tcTyClsInstDecls tycl_decls deriv_decls binds  = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $    tcAddPatSynPlaceholders (getPatSynBinds binds) $-   do { (tcg_env, inst_info, datafam_deriv_info)+   do { (tcg_env, inst_info, deriv_info)           <- tcTyAndClassDecls tycl_decls ;       ; setGblEnv tcg_env $ do {           -- With the @TyClDecl@s and @InstDecl@s checked we're ready to@@ -1687,9 +1696,8 @@           -- Careful to quit now in case there were instance errors, so that           -- the deriving errors don't pile up as well.           ; failIfErrsM-          ; let tyclds = tycl_decls >>= group_tyclds           ; (tcg_env', inst_info', val_binds)-              <- tcInstDeclsDeriv datafam_deriv_info tyclds deriv_decls+              <- tcInstDeclsDeriv deriv_info deriv_decls           ; setGblEnv tcg_env' $ do {                 failIfErrsM               ; pure (tcg_env', inst_info' ++ inst_info, val_binds)@@ -1735,7 +1743,7 @@         ; (ev_binds, main_expr)                <- checkConstraints skol_info [] [] $                   addErrCtxt mainCtxt    $-                  tcMonoExpr (cL loc (HsVar noExt (cL loc main_name)))+                  tcMonoExpr (cL loc (HsVar noExtField (cL loc main_name)))                              (mkCheckExpType io_ty)                  -- See Note [Root-main Id]@@ -1751,7 +1759,7 @@               -- The ev_binds of the `main` function may contain deferred               -- type error when type of `main` is not `IO a`. The `ev_binds`               -- must be put inside `runMainIO` to ensure the deferred type-              -- error can be emitted correctly. See Trac #13838.+              -- error can be emitted correctly. See #13838.               ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) $                         mkHsDictLet ev_binds main_expr               ; main_bind = mkVarBind root_main_id rhs }@@ -1837,7 +1845,7 @@ -- Initialise the tcg_inst_env with instances from all home modules. -- This mimics the more selective call to hptInstances in tcRnImports runTcInteractive hsc_env thing_inside-  = initTcInteractive hsc_env $ withTcPlugins hsc_env $+  = initTcInteractive hsc_env $ withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $     do { traceTc "setInteractiveContext" $             vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))                  , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts)@@ -1883,7 +1891,8 @@                          , tcg_imports      = imports                          } -       ; lcl_env' <- tcExtendLocalTypeEnv lcl_env lcl_ids+             lcl_env' = tcExtendLocalTypeEnv lcl_env lcl_ids+        ; setEnvs (gbl_env', lcl_env') thing_inside }   where     (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True)@@ -1925,9 +1934,8 @@ types.  If we don't register these free TyVars as global TyVars then the typechecker will try to quantify over them and fall over in skolemiseQuantifiedTyVar. so we must add any free TyVars to the-typechecker's global TyVar set.  That is most conveniently by using-tcExtendLocalTypeEnv, which automatically extends the global TyVar-set.+typechecker's global TyVar set.  That is done by using+tcExtendLocalTypeEnv.  We do this by splitting out the Ids with open types, using 'is_closed' to do the partition.  The top-level things go in the global TypeEnv;@@ -2063,35 +2071,35 @@               -- (if we are at a breakpoint, say).  We must put those free vars                -- [let it = expr]-              let_stmt  = cL loc $ LetStmt noExt $ noLoc $ HsValBinds noExt+              let_stmt  = cL loc $ LetStmt noExtField $ noLoc $ HsValBinds noExtField                            $ XValBindsLR                                (NValBinds [(NonRecursive,unitBag the_bind)] [])                -- [it <- e]-              bind_stmt = cL loc $ BindStmt noExt-                                       (cL loc (VarPat noExt (cL loc fresh_it)))+              bind_stmt = cL loc $ BindStmt noExtField+                                       (cL loc (VarPat noExtField (cL loc fresh_it)))                                        (nlHsApp ghciStep rn_expr)                                        (mkRnSyntaxExpr bindIOName)                                        noSyntaxExpr                -- [; print it]-              print_it  = cL loc $ BodyStmt noExt+              print_it  = cL loc $ BodyStmt noExtField                                            (nlHsApp (nlHsVar interPrintName)                                            (nlHsVar fresh_it))                                            (mkRnSyntaxExpr thenIOName)                                                   noSyntaxExpr                -- NewA-              no_it_a = cL loc $ BodyStmt noExt (nlHsApps bindIOName+              no_it_a = cL loc $ BodyStmt noExtField (nlHsApps bindIOName                                        [rn_expr , nlHsVar interPrintName])                                        (mkRnSyntaxExpr thenIOName)                                        noSyntaxExpr -              no_it_b = cL loc $ BodyStmt noExt (rn_expr)+              no_it_b = cL loc $ BodyStmt noExtField (rn_expr)                                        (mkRnSyntaxExpr thenIOName)                                        noSyntaxExpr -              no_it_c = cL loc $ BodyStmt noExt+              no_it_c = cL loc $ BodyStmt noExtField                                       (nlHsApp (nlHsVar interPrintName) rn_expr)                                       (mkRnSyntaxExpr thenIOName)                                       noSyntaxExpr@@ -2150,10 +2158,10 @@ expression gets evaluated right away anyway. It also would potentially emit two redundant type-error warnings, one from each plan. -Trac #14963 reveals another bug that when deferred type errors is enabled+#14963 reveals another bug that when deferred type errors is enabled in GHCi, any reference of imported/loaded variables (directly or indirectly) in interactively issued naked expressions will cause ghc panic. See more-detailed dicussion in Trac #14963.+detailed dicussion in #14963.  The interactively issued declarations, statements, as well as the modules loaded into GHCi, are not affected. That means, for declaration, you could@@ -2225,7 +2233,7 @@            ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM            ; return stuff }       where-        print_v  = cL loc $ BodyStmt noExt (nlHsApp (nlHsVar printName)+        print_v  = cL loc $ BodyStmt noExtField (nlHsApp (nlHsVar printName)                                     (nlHsVar v))                                     (mkRnSyntaxExpr thenIOName) noSyntaxExpr @@ -2311,14 +2319,15 @@         ioM     = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)          step_ty = noLoc $ HsForAllTy-                     { hst_bndrs = [noLoc $ UserTyVar noExt (noLoc a_tv)]-                     , hst_xforall = noExt+                     { hst_fvf = ForallInvis+                     , hst_bndrs = [noLoc $ UserTyVar noExtField (noLoc a_tv)]+                     , hst_xforall = noExtField                      , hst_body  = nlHsFunTy ghciM ioM }          stepTy :: LHsSigWcType GhcRn         stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty) -    return (noLoc $ ExprWithTySig noExt (nlHsVar ghciStepIoMName) stepTy)+    return (noLoc $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy)  isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name) isGHCiMonad hsc_env ty@@ -2359,8 +2368,9 @@     uniq <- newUnique ;     let { fresh_it  = itName uniq (getLoc rdr_expr)         ; orig = lexprCtOrigin rn_expr } ;-    (tclvl, lie, res_ty)-          <- pushLevelAndCaptureConstraints $+    ((tclvl, res_ty), lie)+          <- captureTopConstraints $+             pushTcLevelM          $              do { (_tc_expr, expr_ty) <- tcInferSigma rn_expr                 ; if inst                   then snd <$> deeplyInstantiate orig expr_ty@@ -2377,7 +2387,8 @@     _ <- perhaps_disable_default_warnings $          simplifyInteractive residual ; -    let { all_expr_ty = mkInvForAllTys qtvs (mkLamTypes dicts res_ty) } ;+    let { all_expr_ty = mkInvForAllTys qtvs $+                        mkPhiTy (map idType dicts) res_ty } ;     ty <- zonkTcType all_expr_ty ;      -- We normalise type families, so that the type of an expression is the@@ -2411,10 +2422,11 @@  -- tcRnType just finds the kind of a type tcRnType :: HscEnv+         -> ZonkFlexi          -> Bool        -- Normalise the returned type          -> LHsType GhcPs          -> IO (Messages, Maybe (Type, Kind))-tcRnType hsc_env normalise rdr_type+tcRnType hsc_env flexi normalise rdr_type   = runTcInteractive hsc_env $     setXOptM LangExt.PolyKinds $   -- See Note [Kind-generalise in tcRnType]     do { (HsWC { hswc_ext = wcs, hswc_body = rn_type }, _fvs)@@ -2423,6 +2435,8 @@                   -- generalisation; e.g.   :kind (T _)        ; failIfErrsM +        -- We follow Note [Recipe for checking a signature] in TcHsType here+         -- Now kind-check the type         -- It can have any rank or kind         -- First bring into scope any wildcards@@ -2431,15 +2445,16 @@                         -- must push level to satisfy level precondition of                         -- kindGeneralize, below                        solveEqualities       $-                       tcWildCardBinders wcs $ \ wcs' ->-                       do { emitWildCardHoleConstraints wcs'+                       tcNamedWildCardBinders wcs $ \ wcs' ->+                       do { emitNamedWildCardHoleConstraints wcs'                           ; tcLHsTypeUnsaturated rn_type }         -- Do kind generalisation; see Note [Kind-generalise in tcRnType]-       ; kind <- zonkTcType kind-       ; kvs <- kindGeneralize kind-       ; ty  <- zonkTcTypeToType ty+       ; kvs <- kindGeneralizeAll kind+       ; e <- mkEmptyZonkEnv flexi +       ; ty  <- zonkTcTypeToTypeX e ty+        -- Do validity checking on type        ; checkValidType (GhciCtxt True) ty @@ -2871,6 +2886,30 @@ getTcPlugins :: DynFlags -> [TcRnMonad.TcPlugin] getTcPlugins dflags = catMaybes $ mapPlugins dflags (\p args -> tcPlugin p args) ++withHoleFitPlugins :: HscEnv -> TcM a -> TcM a+withHoleFitPlugins hsc_env m =+  case (getHfPlugins (hsc_dflags hsc_env)) of+    [] -> m  -- Common fast case+    plugins -> do (plugins,stops) <- unzip `fmap` mapM startPlugin plugins+                  -- This ensures that hfPluginStop is called even if a type+                  -- error occurs during compilation.+                  eitherRes <- tryM $ do+                    updGblEnv (\e -> e { tcg_hf_plugins = plugins }) m+                  sequence_ stops+                  case eitherRes of+                    Left _ -> failM+                    Right res -> return res+  where+    startPlugin (HoleFitPluginR init plugin stop) =+      do ref <- init+         return (plugin ref, stop ref)++getHfPlugins :: DynFlags -> [HoleFitPluginR]+getHfPlugins dflags =+  catMaybes $ mapPlugins dflags (\p args -> holeFitPlugin p args)++ runRenamerPlugin :: TcGblEnv                  -> HsGroup GhcRn                  -> TcM (TcGblEnv, HsGroup GhcRn)@@ -2904,7 +2943,8 @@       gbl_env  mark_plugin_unsafe :: DynFlags -> TcM ()-mark_plugin_unsafe dflags = recordUnsafeInfer pluginUnsafe+mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $+  recordUnsafeInfer pluginUnsafe   where     unsafeText = "Use of plugins makes the module unsafe"     pluginUnsafe = unitBag ( mkPlainWarnMsg dflags noSrcSpan
compiler/typecheck/TcRnExports.hs view
@@ -9,7 +9,7 @@  import GhcPrelude -import HsSyn+import GHC.Hs import PrelNames import RdrName import TcRnMonad@@ -65,7 +65,7 @@  Note [Exports of data families] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose you see (Trac #5306)+Suppose you see (#5306)         module M where           import X( F )           data instance F Int = FInt@@ -92,7 +92,7 @@  Note [Avails of associated data families] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose you have (Trac #16077)+Suppose you have (#16077)      {-# LANGUAGE TypeFamilies #-}     module A (module A) where@@ -170,22 +170,25 @@        -- list, to avoid bleating about re-exporting a deprecated        -- thing (especially via 'module Foo' export item)    do   {-        -- In interactive mode, we behave as if he had-        -- written "module Main where ..."         ; dflags <- getDynFlags         ; let is_main_mod = mainModIs dflags == this_mod         ; let default_main = case mainFunIs dflags of                  Just main_fun                      | is_main_mod -> mkUnqual varName (fsLit main_fun)                  _                 -> main_RDR_Unqual+        ; has_main <- (not . null) <$> lookupInfoOccRn default_main -- #17832+        -- If a module has no explicit header, and it has one or more main+        -- functions in scope, then add a header like+        -- "module Main(main) where ..."                               #13839+        -- See Note [Modules without a module header]         ; let real_exports                  | explicit_mod = exports-                 | ghcLink dflags == LinkInMemory = Nothing-                 | otherwise-                          = Just (noLoc [noLoc (IEVar noExt+                 | has_main+                          = Just (noLoc [noLoc (IEVar noExtField                                      (noLoc (IEName $ noLoc default_main)))])                         -- ToDo: the 'noLoc' here is unhelpful if 'main'                         --       turns out to be out of scope+                 | otherwise = Nothing          ; let do_it = exports_from_avail real_exports rdr_env imports this_mod         ; (rn_exports, final_avails)@@ -267,7 +270,7 @@      -- See Note [Avails of associated data families]     expand_tyty_gre :: GlobalRdrElt -> [GlobalRdrElt]-    expand_tyty_gre (gre @ GRE { gre_name = me, gre_par = ParentIs p })+    expand_tyty_gre (gre@GRE { gre_name = me, gre_par = ParentIs p })       | isTyConName p, isTyConName me = [gre, gre{ gre_par = NoParent }]     expand_tyty_gre gre = [gre] @@ -315,7 +318,7 @@                              , ppr new_exports ])               ; return (Just ( ExportAccum occs' mods-                            , ( cL loc (IEModuleContents noExt lmod)+                            , ( cL loc (IEModuleContents noExtField lmod)                               , new_exports))) }      exports_from_item acc@(ExportAccum occs mods) (dL->L loc ie)@@ -338,18 +341,18 @@     lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo)     lookup_ie (IEVar _ (dL->L l rdr))         = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr-             return (IEVar noExt (cL l (replaceWrappedName rdr name)), avail)+             return (IEVar noExtField (cL l (replaceWrappedName rdr name)), avail)      lookup_ie (IEThingAbs _ (dL->L l rdr))         = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr-             return (IEThingAbs noExt (cL l (replaceWrappedName rdr name))+             return (IEThingAbs noExtField (cL l (replaceWrappedName rdr name))                     , avail)      lookup_ie ie@(IEThingAll _ n')         = do             (n, avail, flds) <- lookup_ie_all ie n'             let name = unLoc n-            return (IEThingAll noExt (replaceLWrappedName n' (unLoc n))+            return (IEThingAll noExtField (replaceLWrappedName n' (unLoc n))                    , AvailTC name (name:avail) flds)  @@ -362,7 +365,7 @@                 NoIEWildcard -> return (lname, [], [])                 IEWildcard _ -> lookup_ie_all ie l             let name = unLoc lname-            return (IEThingWith noExt (replaceLWrappedName l name) wc subs+            return (IEThingWith noExtField (replaceLWrappedName l name) wc subs                                 (flds ++ (map noLoc all_flds)),                     AvailTC name (name : avails ++ all_avail)                                  (map unLoc flds ++ all_flds))@@ -404,10 +407,10 @@     -------------     lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn)     lookup_doc_ie (IEGroup _ lev doc) = do rn_doc <- rnHsDoc doc-                                           return (IEGroup noExt lev rn_doc)+                                           return (IEGroup noExtField lev rn_doc)     lookup_doc_ie (IEDoc _ doc)       = do rn_doc <- rnHsDoc doc-                                           return (IEDoc noExt rn_doc)-    lookup_doc_ie (IEDocNamed _ str)  = return (IEDocNamed noExt str)+                                           return (IEDoc noExtField rn_doc)+    lookup_doc_ie (IEDocNamed _ str)  = return (IEDocNamed noExtField str)     lookup_doc_ie _ = panic "lookup_doc_ie"    -- Other cases covered earlier      -- In an export item M.T(A,B,C), we want to treat the uses of@@ -436,8 +439,40 @@ -- Renaming and typechecking of exports happens after everything else has -- been typechecked. +{-+Note [Modules without a module header]+-------------------------------------------------- +The Haskell 2010 report says in section 5.1: +>> An abbreviated form of module, consisting only of the module body, is+>> permitted. If this is used, the header is assumed to be+>> ‘module Main(main) where’.++For modules without a module header, this is implemented the+following way:++If the module has a main function in scope:+   Then create a module header and export the main function,+   as if a module header like ‘module Main(main) where...’ would exist.+   This has the effect to mark the main function and all top level+   functions called directly or indirectly via main as 'used',+   and later on, unused top-level functions can be reported correctly.+   There is no distinction between GHC and GHCi.+If the module has several main functions in scope:+   Then generate a header as above. The ambiguity is reported later in+   module  `TcRnDriver.hs` function `check_main`.+If the module has NO main function:+   Then export all top-level functions. This marks all top level+   functions as 'used'.+   In GHCi this has the effect, that we don't get any 'non-used' warnings.+   In GHC, however, the 'has-main-module' check in the module+   compiler/typecheck/TcRnDriver (functions checkMain / check-main) fires,+   and we get the error:+      The IO action ‘main’ is not defined in module ‘Main’+-}++ -- Renaming exports lists is a minefield. Five different things can appear in -- children export lists ( T(A, B, C) ). -- 1. Record selectors@@ -688,12 +723,12 @@ --        import A( f ) --        import B( f ) ----- Example of "yes" (Trac #2436)+-- Example of "yes" (#2436) --    module M( C(..), T(..) ) where --         class C a where { data T a } --         instance C Int where { data T Int = TInt } ----- Example of "yes" (Trac #2436)+-- Example of "yes" (#2436) --    module Foo ( T ) where --      data family T a --    module Bar ( T(..), module Foo ) where@@ -748,7 +783,7 @@   text "In the" <+> text (herald ++ ":") <+> ppr exp  -addExportErrCtxt :: (OutputableBndrId (GhcPass p))+addExportErrCtxt :: (OutputableBndrId p)                  => IE (GhcPass p) -> TcM a -> TcM a addExportErrCtxt ie = addErrCtxt exportCtxt   where
compiler/typecheck/TcRnMonad.hs view
@@ -75,7 +75,6 @@   askNoErrs, discardErrs, tryTcDiscardingErrs,   checkNoErrs, whenNoErrs,   ifErrsM, failIfErrsM,-  checkTH, failTH,    -- * Context management for the type checker   getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,@@ -104,7 +103,8 @@   pushTcLevelM_, pushTcLevelM, pushTcLevelsM,   getTcLevel, setTcLevel, isTouchableTcM,   getLclTypeEnv, setLclTypeEnv,-  traceTcConstraints, emitWildCardHoleConstraints,+  traceTcConstraints,+  emitNamedWildCardHoleConstraints, emitAnonWildCardHoleConstraint,    -- * Template Haskell context   recordThUse, recordThSpliceUse, recordTopLevelSpliceLoc,@@ -140,15 +140,17 @@   module IOEnv   ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import TcRnTypes        -- Re-export all import IOEnv            -- Re-export all+import Constraint import TcEvidence+import TcOrigin -import HsSyn hiding (LIE)+import GHC.Hs hiding (LIE) import HscTypes import Module import RdrName@@ -175,7 +177,7 @@ import Panic import Util import Annotations-import BasicTypes( TopLevelFlag )+import BasicTypes( TopLevelFlag, TypeOrKind(..) ) import Maybes import CostCentreState @@ -312,6 +314,7 @@                 tcg_safeInfer      = infer_var,                 tcg_dependent_files = dependent_files_var,                 tcg_tc_plugins     = [],+                tcg_hf_plugins     = [],                 tcg_top_loc        = loc,                 tcg_static_wc      = static_wc_var,                 tcg_complete_matches = [],@@ -330,8 +333,7 @@               -> TcM r               -> IO (Messages, Maybe r) initTcWithGbl hsc_env gbl_env loc do_this- = do { tvs_var      <- newIORef emptyVarSet-      ; lie_var      <- newIORef emptyWC+ = do { lie_var      <- newIORef emptyWC       ; errs_var     <- newIORef (emptyBag, emptyBag)       ; let lcl_env = TcLclEnv {                 tcl_errs       = errs_var,@@ -343,7 +345,6 @@                 tcl_arrow_ctxt = NoArrowCtxt,                 tcl_env        = emptyNameEnv,                 tcl_bndrs      = [],-                tcl_tyvars     = tvs_var,                 tcl_lie        = lie_var,                 tcl_tclvl      = topTcLevel                 }@@ -358,7 +359,7 @@       -- If we succeed (maybe_res = Just r), there should be       -- no unsolved constraints.  But if we exit via an       -- exception (maybe_res = Nothing), we may have skipped-      -- solving, so don't panic then (Trac #13466)+      -- solving, so don't panic then (#13466)       ; lie <- readIORef (tcl_lie lcl_env)       ; when (isJust maybe_res && not (isEmptyWC lie)) $         pprPanic "initTc: unsolved constraints" (ppr lie)@@ -401,17 +402,14 @@ ************************************************************************ -} -initTcRnIf :: Char              -- Tag for unique supply+initTcRnIf :: Char              -- ^ Mask for unique supply            -> HscEnv            -> gbl -> lcl            -> TcRnIf gbl lcl a            -> IO a-initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside-   = do { us     <- mkSplitUniqSupply uniq_tag ;-        ; us_var <- newIORef us ;--        ; let { env = Env { env_top = hsc_env,-                            env_us  = us_var,+initTcRnIf uniq_mask hsc_env gbl_env lcl_env thing_inside+   = do { let { env = Env { env_top = hsc_env,+                            env_um  = uniq_mask,                             env_gbl = gbl_env,                             env_lcl = lcl_env} } @@ -599,27 +597,15 @@  newUnique :: TcRnIf gbl lcl Unique newUnique- = do { env <- getEnv ;-        let { u_var = env_us env } ;-        us <- readMutVar u_var ;-        case takeUniqFromSupply us of { (uniq, us') -> do {-        writeMutVar u_var us' ;-        return $! uniq }}}-   -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving-   -- a chain of unevaluated supplies behind.-   -- NOTE 2: we use the uniq in the supply from the MutVar directly, and-   -- throw away one half of the new split supply.  This is safe because this-   -- is the only place we use that unique.  Using the other half of the split-   -- supply is safer, but slower.+ = do { env <- getEnv+      ; let mask = env_um env+      ; liftIO $! uniqFromMask mask }  newUniqueSupply :: TcRnIf gbl lcl UniqSupply newUniqueSupply- = do { env <- getEnv ;-        let { u_var = env_us env } ;-        us <- readMutVar u_var ;-        case splitUniqSupply us of { (us1,us2) -> do {-        writeMutVar u_var us1 ;-        return us2 }}}+ = do { env <- getEnv+      ; let mask = env_um env+      ; liftIO $! mkSplitUniqSupply mask }  cloneLocalName :: Name -> TcM Name -- Make a fresh Internal name with the same OccName and SrcSpan@@ -1021,17 +1007,6 @@ -- Useful to avoid error cascades failIfErrsM = ifErrsM failM (return ()) -checkTH :: a -> String -> TcRn ()-checkTH _ _ = return () -- OK--failTH :: Outputable a => a -> String -> TcRn x-failTH e what  -- Raise an error in a stage-1 compiler-  = failWithTc (vcat [ hang (char 'A' <+> text what-                             <+> text "requires GHC with interpreter support:")-                          2 (ppr e)-                     , text "Perhaps you are using a stage-1 compiler?" ])-- {- ********************************************************************* *                                                                      *         Context management for the type checker@@ -1677,8 +1652,7 @@ setLclTypeEnv lcl_env thing_inside   = updLclEnv upd thing_inside   where-    upd env = env { tcl_env = tcl_env lcl_env,-                    tcl_tyvars = tcl_tyvars lcl_env }+    upd env = env { tcl_env = tcl_env lcl_env }  traceTcConstraints :: String -> TcM () traceTcConstraints msg@@ -1688,9 +1662,17 @@          hang (text (msg ++ ": LIE:")) 2 (ppr lie)        } -emitWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()-emitWildCardHoleConstraints wcs+emitAnonWildCardHoleConstraint :: TcTyVar -> TcM ()+emitAnonWildCardHoleConstraint tv   = do { ct_loc <- getCtLocM HoleOrigin Nothing+       ; emitInsolubles $ unitBag $+         CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv+                                      , ctev_loc  = ct_loc }+                  , cc_hole = TypeHole (mkTyVarOcc "_") } }++emitNamedWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()+emitNamedWildCardHoleConstraints wcs+  = do { ct_loc <- getCtLocM HoleOrigin Nothing        ; emitInsolubles $ listToBag $          map (do_one ct_loc) wcs }   where@@ -1702,14 +1684,14 @@        where          real_span = case nameSrcSpan name of                            RealSrcSpan span  -> span-                           UnhelpfulSpan str -> pprPanic "emitWildCardHoleConstraints"+                           UnhelpfulSpan str -> pprPanic "emitNamedWildCardHoleConstraints"                                                       (ppr name <+> quotes (ftext str))                -- Wildcards are defined locally, and so have RealSrcSpans          ct_loc' = setCtLocSpan ct_loc real_span  {- Note [Constraints and errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (Trac #12124):+Consider this (#12124):    foo :: Maybe Int   foo = return (case Left 3 of@@ -1737,7 +1719,7 @@ captureConstraints, and discard all the constraints. Some of those constraints might be "variable out of scope" Hole constraints, and that might have been the actual original cause of the exception!  For-example (Trac #12529):+example (#12529):    f = p @ Int Here 'p' is out of scope, so we get an insolube Hole constraint. But the visible type application fails in the monad (thows an exception).@@ -1748,7 +1730,7 @@   - insolublesOnly in tryCaptureConstraints   - emitConstraints in the Left case of captureConstraints -Hover note that fresly-generated constraints like (Int ~ Bool), or+However note that freshly-generated constraints like (Int ~ Bool), or ((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as insoluble.  The constraint solver does that.  So they'll be discarded. That's probably ok; but see th/5358 as a not-so-good example:@@ -1837,13 +1819,13 @@ finalSafeMode dflags tcg_env = do     safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env)     return $ case safeHaskell dflags of-        Sf_None | safeInferOn dflags && safeInf -> Sf_Safe+        Sf_None | safeInferOn dflags && safeInf -> Sf_SafeInferred                 | otherwise                     -> Sf_None         s -> s  -- | Switch instances to safe instances if we're in Safe mode. fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]-fixSafeInstances sfMode | sfMode /= Sf_Safe = id+fixSafeInstances sfMode | sfMode /= Sf_Safe && sfMode /= Sf_SafeInferred = id fixSafeInstances _ = map fixSafe   where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True }                        in inst { is_flag = new_flag }@@ -1966,12 +1948,8 @@ -- signatures, which is pretty benign  forkM_maybe doc thing_inside- -- NB: Don't share the mutable env_us with the interleaved thread since env_us- --     does not get updated atomically (e.g. in newUnique and newUniqueSupply).- = do { child_us <- newUniqueSupply-      ; child_env_us <- newMutVar child_us-        -- see Note [Masking exceptions in forkM_maybe]-      ; unsafeInterleaveM $ uninterruptibleMaskM_ $ updEnv (\env -> env { env_us = child_env_us }) $+ = do { -- see Note [Masking exceptions in forkM_maybe]+      ; unsafeInterleaveM $ uninterruptibleMaskM_ $         do { traceIf (text "Starting fork {" <+> doc)            ; mb_res <- tryM $                        updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
compiler/typecheck/TcRules.hs view
@@ -13,10 +13,13 @@  import GhcPrelude -import HsSyn+import GHC.Hs import TcRnTypes import TcRnMonad import TcSimplify+import Constraint+import Predicate+import TcOrigin import TcMType import TcType import TcHsType@@ -66,10 +69,10 @@ tcRuleDecls (HsRules { rds_src = src                      , rds_rules = decls })    = do { tc_decls <- mapM (wrapLocM tcRule) decls-        ; return $ HsRules { rds_ext   = noExt+        ; return $ HsRules { rds_ext   = noExtField                            , rds_src   = src                            , rds_rules = tc_decls } }-tcRuleDecls (XRuleDecls _) = panic "tcRuleDecls"+tcRuleDecls (XRuleDecls nec) = noExtCon nec  tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTcId) tcRule (HsRule { rd_ext  = ext@@ -110,12 +113,10 @@        -- during zonking (see TcHsSyn.zonkRule)         ; let tpl_ids = lhs_evs ++ id_bndrs-       ; gbls  <- tcGetGlobalTyCoVars -- Even though top level, there might be top-level-                                      -- monomorphic bindings from the MR; test tc111        ; forall_tkvs <- candidateQTyVarsOfTypes $                         map (mkSpecForAllTys tv_bndrs) $  -- don't quantify over lexical tyvars                         rule_ty : map idType tpl_ids-       ; qtkvs <- quantifyTyVars gbls forall_tkvs+       ; qtkvs <- quantifyTyVars forall_tkvs        ; traceTc "tcRule" (vcat [ pprFullRuleName rname                                 , ppr forall_tkvs                                 , ppr qtkvs@@ -141,10 +142,11 @@                          , rd_name = rname                          , rd_act = act                          , rd_tyvs = ty_bndrs -- preserved for ppr-ing-                         , rd_tmvs = map (noLoc . RuleBndr noExt . noLoc) (all_qtkvs ++ tpl_ids)+                         , rd_tmvs = map (noLoc . RuleBndr noExtField . noLoc)+                                         (all_qtkvs ++ tpl_ids)                          , rd_lhs  = mkHsDictLet lhs_binds lhs'                          , rd_rhs  = mkHsDictLet rhs_binds rhs' } }-tcRule (XRuleDecl _) = panic "tcRule"+tcRule (XRuleDecl nec) = noExtCon nec  generateRuleConstraints :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn]                         -> LHsExpr GhcRn -> LHsExpr GhcRn@@ -159,7 +161,7 @@               -- bndr_wanted constraints can include wildcard hole               -- constraints, which we should not forget about.               -- It may mention the skolem type variables bound by-              -- the RULE.  c.f. Trac #10072+              -- the RULE.  c.f. #10072         ; tcExtendTyVarEnv tv_bndrs $          tcExtendIdEnv    id_bndrs $@@ -203,7 +205,7 @@         ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $                                    tcRuleTmBndrs rule_bndrs         ; return (map snd tvs ++ tyvars, id : tmvars) }-tcRuleTmBndrs (L _ (XRuleBndr _) : _) = panic "tcRuleTmBndrs"+tcRuleTmBndrs (L _ (XRuleBndr nec) : _) = noExtCon nec  ruleCtxt :: FastString -> SDoc ruleCtxt name = text "When checking the transformation rule" <+>@@ -412,7 +414,7 @@ -- -- NB: we must look inside implications, because with --     -fdefer-type-errors we generate implications rather eagerly;---     see TcUnify.implicationNeeded. Not doing so caused Trac #14732.+--     see TcUnify.implicationNeeded. Not doing so caused #14732. -- -- Unlike simplifyInfer, we don't leave the WantedConstraints unchanged, --   and attempt to solve them from the quantified constraints.  That
compiler/typecheck/TcSMonad.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, TypeFamilies #-}+{-# LANGUAGE CPP, DeriveFunctor, TypeFamilies #-}  -- Type definitions for the constraint solver module TcSMonad (@@ -19,7 +19,7 @@     nestTcS, nestImplicTcS, setEvBindsTcS,     checkConstraintsTcS, checkTvConstraintsTcS, -    runTcPluginTcS, addUsedGRE, addUsedGREs,+    runTcPluginTcS, addUsedGRE, addUsedGREs, keepAlive,     matchGlobalInst, TcM.ClsInstResult(..),      QCInst(..),@@ -33,8 +33,10 @@     MaybeNew(..), freshGoals, isFresh, getEvExpr,      newTcEvBinds, newNoTcEvBinds,-    newWantedEq, emitNewWantedEq,-    newWanted, newWantedEvVar, newWantedNC, newWantedEvVarNC, newDerivedNC,+    newWantedEq, newWantedEq_SI, emitNewWantedEq,+    newWanted, newWanted_SI, newWantedEvVar,+    newWantedNC, newWantedEvVarNC,+    newDerivedNC,     newBoundEvVarId,     unifyTyVar, unflattenFmv, reportUnifications,     setEvBind, setWantedEq,@@ -77,7 +79,7 @@      -- Inert CTyEqCans     EqualCtList, findTyEqs, foldTyEqs, isInInertEqs,-    lookupFlattenTyVar, lookupInertTyVar,+    lookupInertTyVar,      -- Inert solved dictionaries     addSolvedDict, lookupSolvedDict,@@ -121,7 +123,7 @@                                              -- here ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -137,9 +139,7 @@ import qualified ClsInst as TcM( matchGlobalInst, ClsInstResult(..) ) import qualified TcEnv as TcM        ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl )-import PrelNames( heqTyConKey, eqTyConKey )-import ClsInst( InstanceWhat(..) )-import Kind+import ClsInst( InstanceWhat(..), safeOverlap, instanceReturnsDictCon ) import TcType import DynFlags import Type@@ -163,6 +163,9 @@ import UniqSupply import Util import TcRnTypes+import TcOrigin+import Constraint+import Predicate  import Unique import UniqFM@@ -212,7 +215,7 @@   and then kicking it out later.  That's extra work compared to just   doing the equality first. -* (Avoiding fundep iteration) As Trac #14723 showed, it's possible to+* (Avoiding fundep iteration) As #14723 showed, it's possible to   get non-termination if we       - Emit the Derived fundep equalities for a class constraint,         generating some fresh unification variables.@@ -229,7 +232,7 @@ * (Kick-out) We want to apply this priority scheme to kicked-out   constraints too (see the call to extendWorkListCt in kick_out_rewritable   E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become-  homo-kinded when kicked out, and hence we want to priotitise it.+  homo-kinded when kicked out, and hence we want to prioritise it.  * (Derived equalities) Originally we tried to postpone processing   Derived equalities, in the hope that we might never need to deal@@ -245,7 +248,7 @@  Failing to prioritise these is inefficient (more kick-outs etc). But, worse, it can prevent us spotting a "recursive knot" among-Wanted constraints.  See comment:10 of Trac #12734 for a worked-out+Wanted constraints.  See comment:10 of #12734 for a worked-out example.  So we arrange to put these particular class constraints in the wl_eqs.@@ -253,6 +256,7 @@   NB: since we do not currently apply the substitution to the   inert_solved_dicts, the knot-tying still seems a bit fragile.   But this makes it better.+ -}  -- See Note [WorkList priorities]@@ -328,8 +332,7 @@        -> extendWorkListEq ct wl       ClassPred cls _  -- See Note [Prioritise class equalities]-       |  cls `hasKey` heqTyConKey-       || cls `hasKey` eqTyConKey+       |  isEqPredClass cls        -> extendWorkListEq ct wl       _ -> extendWorkListNonEq ct wl@@ -483,6 +486,63 @@     d2 = d1  See Note [Example of recursive dictionaries]++VERY IMPORTANT INVARIANT:++ (Solved Dictionary Invariant)+    Every member of the inert_solved_dicts is the result+    of applying an instance declaration that "takes a step"++    An instance "takes a step" if it has the form+        dfunDList d1 d2 = MkD (...) (...) (...)+    That is, the dfun is lazy in its arguments, and guarantees to+    immediately return a dictionary constructor.  NB: all dictionary+    data constructors are lazy in their arguments.++    This property is crucial to ensure that all dictionaries are+    non-bottom, which in turn ensures that the whole "recursive+    dictionary" idea works at all, even if we get something like+        rec { d = dfunDList d dx }+    See Note [Recursive superclasses] in TcInstDcls.++ Reason:+   - All instances, except two exceptions listed below, "take a step"+     in the above sense++   - Exception 1: local quantified constraints have no such guarantee;+     indeed, adding a "solved dictionary" when appling a quantified+     constraint led to the ability to define unsafeCoerce+     in #17267.++   - Exception 2: the magic built-in instace for (~) has no+     such guarantee.  It behaves as if we had+         class    (a ~# b) => (a ~ b) where {}+         instance (a ~# b) => (a ~ b) where {}+     The "dfun" for the instance is strict in the coercion.+     Anyway there's no point in recording a "solved dict" for+     (t1 ~ t2); it's not going to allow a recursive dictionary+     to be constructed.  Ditto (~~) and Coercible.++THEREFORE we only add a "solved dictionary"+  - when applying an instance declaration+  - subject to Exceptions 1 and 2 above++In implementation terms+  - TcSMonad.addSolvedDict adds a new solved dictionary,+    conditional on the kind of instance++  - It is only called when applying an instance decl,+    in TcInteract.doTopReactDict++  - ClsInst.InstanceWhat says what kind of instance was+    used to solve the constraint.  In particular+      * LocalInstance identifies quantified constraints+      * BuiltinEqInstance identifies the strange built-in+        instances for equality.++  - ClsInst.instanceReturnsDictCon says which kind of+    instance guarantees to return a dictionary constructor+ Other notes about solved dictionaries  * See also Note [Do not add superclasses of solved dictionaries]@@ -490,7 +550,7 @@ * The inert_solved_dicts field is not rewritten by equalities,   so it may get out of date. -* THe inert_solved_dicts are all Wanteds, never givens+* The inert_solved_dicts are all Wanteds, never givens  * We only cache dictionaries from top-level instances, not from   local quantified constraints.  Reason: if we cached the latter@@ -500,8 +560,8 @@  Note [Do not add superclasses of solved dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Every member of inert_solved_dicts is the result of applying a dictionary-function, NOT of applying superclass selection to anything.+Every member of inert_solved_dicts is the result of applying a+dictionary function, NOT of applying superclass selection to anything. Consider          class Ord a => C a where@@ -703,8 +763,7 @@     to the CTyEqCan equalities (modulo canRewrite of course;     eg a wanted cannot rewrite a given) -  * CTyEqCan equalities: see Note [Applying the inert substitution]-                         in TcFlatten+  * CTyEqCan equalities: see Note [inert_eqs: the inert equalities]  Note [EqualCtList invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -980,7 +1039,7 @@ TcType.isTyVarHead. This is encoded in (K3b).  Beware: if we make this test succeed too often, we kick out too much,-and the solver might loop.  Consider (Trac #14363)+and the solver might loop.  Consider (#14363)   work item:   [G] a ~R f b   inert item:  [G] b ~R f a In GHC 8.2 the completeness tests more aggressive, and kicked out@@ -1043,7 +1102,7 @@ Note [The improvement story and derived shadows] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Because Wanteds cannot rewrite Wanteds (see Note [Wanteds do not-rewrite Wanteds] in TcRnTypes), we may miss some opportunities for+rewrite Wanteds] in Constraint), we may miss some opportunities for solving.  Here's a classic example (indexed-types/should_fail/T4093a)      Ambiguity check for f: (Foo e ~ Maybe e) => Foo e@@ -1236,7 +1295,7 @@  Note [Examples of how Derived shadows helps completeness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Trac #10009, a very nasty example:+#10009, a very nasty example:      f :: (UnF (F b) ~ b) => F b -> () @@ -1276,7 +1335,7 @@  But (a) I have been unable to come up with an example of this         happening-    (b) see Trac #12660 for how adding the derived shadows+    (b) see #12660 for how adding the derived shadows         of a Given led to an infinite loop.     (c) It's unlikely that rewriting derived Givens will lead         to a unification because Givens don't mention touchable@@ -1316,7 +1375,7 @@ them.  If we forget the pend_sc flag, our cunning scheme for avoiding generating superclasses repeatedly will fail. -See Trac #11379 for a case of this.+See #11379 for a case of this.  Note [Do not do improvement for WOnly] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1347,7 +1406,7 @@   with the inert [W] C Int b in the inert set; after all,   it's the very constraint from which the [D] C Int Bool   was split!  We can avoid this by not doing improvement-  on [W] constraints. This came up in Trac #12860.+  on [W] constraints. This came up in #12860. -}  maybeEmitShadow :: InertCans -> Ct -> TcS Ct@@ -1459,25 +1518,6 @@       Just (CTyEqCan { cc_rhs = rhs, cc_eq_rel = NomEq } : _ ) -> Just rhs       _                                                        -> Nothing -lookupFlattenTyVar :: InertEqs -> TcTyVar -> TcType--- See Note [lookupFlattenTyVar]-lookupFlattenTyVar ieqs ftv-  = lookupInertTyVar ieqs ftv `orElse` mkTyVarTy ftv--{- Note [lookupFlattenTyVar]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have an injective function F and-  inert_funeqs:   F t1 ~ fsk1-                  F t2 ~ fsk2-  inert_eqs:      fsk1 ~ fsk2--We never rewrite the RHS (cc_fsk) of a CFunEqCan.  But we /do/ want to-get the [D] t1 ~ t2 from the injectiveness of F.  So we look up the-cc_fsk of CFunEqCans in the inert_eqs when trying to find derived-equalities arising from injectivity.--}-- {- ********************************************************************* *                                                                      *                    Inert instances: inert_insts@@ -1500,7 +1540,7 @@  {- Note [Do not add duplicate quantified instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (Trac #15244):+Consider this (#15244):    f :: (C g, D g) => ....   class S g => C g where ...@@ -1551,7 +1591,7 @@           [D] fmv1 ~ fmv2  and now improvement will discover [D] alpha ~ beta. This is important;-eg in Trac #9587.+eg in #9587.  So in kickOutRewritable we look at all the tyvars of the CFunEqCan, including the fsk.@@ -1663,12 +1703,12 @@      kicked_out :: WorkList     -- NB: use extendWorkList to ensure that kicked-out equalities get priority-    -- See Note [Prioritise equality constraints] (Kick-out).+    -- See Note [Prioritise equalities] (Kick-out).     -- The irreds may include non-canonical (hetero-kinded) equality     -- constraints, which perhaps may have become soluble after new_tv     -- is substituted; ditto the dictionaries, which may include (a~b)     -- or (a~~b) constraints.-    kicked_out = foldrBag extendWorkListCt+    kicked_out = foldr extendWorkListCt                           (emptyWorkList { wl_eqs    = tv_eqs_out                                          , wl_funeqs = feqs_out })                           ((dicts_out `andCts` irs_out)@@ -1810,7 +1850,7 @@  Similarly, if we have a CHoleCan, we'd like to rewrite it with any Givens, to give as informative an error messasge as possible-(Trac #12468, #11325).+(#12468, #11325).  Hence:  * In the main simlifier loops in TcSimplify (solveWanteds,@@ -1834,10 +1874,11 @@ addInertSafehask _ item   = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item -insertSafeOverlapFailureTcS :: Ct -> TcS ()+insertSafeOverlapFailureTcS :: InstanceWhat -> Ct -> TcS () -- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify-insertSafeOverlapFailureTcS item-  = updInertCans (\ics -> addInertSafehask ics item)+insertSafeOverlapFailureTcS what item+  | safeOverlap what = return ()+  | otherwise        = updInertCans (\ics -> addInertSafehask ics item)  getSafeOverlapFailures :: TcS Cts -- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify@@ -1846,16 +1887,17 @@       ; return $ foldDicts consCts safehask emptyCts }  ---------------addSolvedDict :: CtEvidence -> Class -> [Type] -> TcS ()--- Add a new item in the solved set of the monad+addSolvedDict :: InstanceWhat -> CtEvidence -> Class -> [Type] -> TcS ()+-- Conditionally add a new item in the solved set of the monad -- See Note [Solved dictionaries]-addSolvedDict item cls tys-  | isIPPred (ctEvPred item)    -- Never cache "solved" implicit parameters (not sure why!)-  = return ()-  | otherwise+addSolvedDict what item cls tys+  | isWanted item+  , instanceReturnsDictCon what   = do { traceTcS "updSolvedSetTcs:" $ ppr item        ; updInertTcS $ \ ics ->              ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } }+  | otherwise+  = return ()  getSolvedDicts :: TcS (DictMap CtEvidence) getSolvedDicts = do { ics <- getTcSInerts; return (inert_solved_dicts ics) }@@ -2054,7 +2096,7 @@ getNoGivenEqs tclvl skol_tvs   = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = irreds })               <- getInertCans-       ; let has_given_eqs = foldrBag ((||) . ct_given_here) False irreds+       ; let has_given_eqs = foldr ((||) . ct_given_here) False irreds                           || anyDVarEnv eqs_given_here ieqs              insols = filterBag insolubleEqCt irreds                       -- Specifically includes ones that originated in some@@ -2157,7 +2199,7 @@ to () in an outer scope.  Then we can float the (alpha ~ Int) out just fine. So when deciding whether the givens contain an equality, we should canonicalise first, rather than just looking at the original-givens (Trac #8644).+givens (#8644).  So we simply look at the inert, canonical Givens and see if there are any equalities among them, the calculation of has_given_eqs.  There@@ -2209,7 +2251,7 @@    so we can safely discard it.  Notably, it doesn't need to be    returned as part of 'fsks' -For an example, see Trac #9211.+For an example, see #9211.  See also TcUnify Note [Deeper level on the left] for how we ensure that the right variable is on the left of the equality when both are@@ -2217,7 +2259,7 @@  You might wonder whether the skokem really needs to be bound "in the very same implication" as the equuality constraint.-(c.f. Trac #15009) Consider this:+(c.f. #15009) Consider this:    data S a where     MkS :: (a ~ Int) => S a@@ -2317,7 +2359,7 @@ ********************************************************************* -}  foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b-foldIrreds k irreds z = foldrBag k z irreds+foldIrreds k irreds z = foldr k z irreds   {- *********************************************************************@@ -2402,7 +2444,7 @@  The call to 'g' gives rise to a Wanted constraint (?x::Int, C a). We must /not/ solve this from the Given (?x::Int, C a), because of-the intervening binding for (?x::Int).  Trac #14218.+the intervening binding for (?x::Int).  #14218.  We deal with this by arranging that we always fail when looking up a tuple constraint that hides an implicit parameter. Not that this applies@@ -2467,7 +2509,7 @@  addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct addDictsByClass m cls items-  = addToUDFM m cls (foldrBag add emptyTM items)+  = addToUDFM m cls (foldr add emptyTM items)   where     add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm     add ct _ = pprPanic "addDictsByClass" (ppr ct)@@ -2601,10 +2643,7 @@     }  ----------------newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a }--instance Functor TcS where-  fmap f m = TcS $ fmap f . unTcS m+newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } deriving (Functor)  instance Applicative TcS where   pure x = TcS (\_ -> return x)@@ -2765,7 +2804,7 @@     cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges]      coercion_cycles = [c | c <- cycles, any is_co_bind c]-    is_co_bind (EvBind { eb_lhs = b }) = isEqPred (varType b)+    is_co_bind (EvBind { eb_lhs = b }) = isEqPrimPred (varType b)      edges :: [ Node EvVar EvBind ]     edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs))@@ -2875,7 +2914,7 @@         ; unless (null wanteds) $          do { ev_binds_var <- TcM.newNoTcEvBinds-            ; imp <- newImplication+            ; imp <- TcM.newImplication             ; let wc = emptyWC { wc_simple = wanteds }                   imp' = imp { ic_tclvl  = new_tclvl                              , ic_skols  = skol_tvs@@ -2914,7 +2953,7 @@                                         thing_inside new_tcs_env         ; ev_binds_var <- TcM.newTcEvBinds-       ; imp <- newImplication+       ; imp <- TcM.newImplication        ; let wc = emptyWC { wc_simple = wanteds }              imp' = imp { ic_tclvl  = new_tclvl                         , ic_skols  = skol_tvs@@ -3069,6 +3108,8 @@ addUsedGRE :: Bool -> GlobalRdrElt -> TcS () addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre +keepAlive :: Name -> TcS ()+keepAlive = wrapTcS . TcM.keepAlive  -- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -3228,6 +3269,7 @@ --       - co :: F tys ~ xi --       - fmv/fsk `notElem` xi --       - fmv not filled (for Wanteds)+--       - xi is flattened (and obeys Note [Almost function-free] in TcRnTypes) -- -- Then for [W] or [WD], we actually fill in the fmv: --      set fmv := xi,@@ -3382,7 +3424,7 @@ -- Make a new variable of the given PredType, -- immediately bind it to the given term -- and return its CtEvidence--- See Note [Bind new Givens immediately] in TcRnTypes+-- See Note [Bind new Givens immediately] in Constraint newGivenEvVar loc (pred, rhs)   = do { new_ev <- newBoundEvVarId pred rhs        ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) }@@ -3401,19 +3443,23 @@ emitNewWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS Coercion -- | Emit a new Wanted equality into the work-list emitNewWantedEq loc role ty1 ty2-  | otherwise   = do { (ev, co) <- newWantedEq loc role ty1 ty2-       ; updWorkListTcS $-         extendWorkListEq (mkNonCanonical ev)+       ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev))        ; return co }  -- | Make a new equality CtEvidence-newWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS (CtEvidence, Coercion)-newWantedEq loc role ty1 ty2+newWantedEq :: CtLoc -> Role -> TcType -> TcType+            -> TcS (CtEvidence, Coercion)+newWantedEq = newWantedEq_SI WDeriv++newWantedEq_SI :: ShadowInfo -> CtLoc -> Role+               -> TcType -> TcType+               -> TcS (CtEvidence, Coercion)+newWantedEq_SI si loc role ty1 ty2   = do { hole <- wrapTcS $ TcM.newCoercionHole pty        ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty)        ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole-                           , ctev_nosh = WDeriv+                           , ctev_nosh = si                            , ctev_loc = loc}                 , mkHoleCo hole ) }   where@@ -3421,35 +3467,44 @@  -- no equalities here. Use newWantedEq instead newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence+newWantedEvVarNC = newWantedEvVarNC_SI WDeriv++newWantedEvVarNC_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS CtEvidence -- Don't look up in the solved/inerts; we know it's not there-newWantedEvVarNC loc pty+newWantedEvVarNC_SI si loc pty   = do { new_ev <- newEvVar pty        ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$                                          pprCtLoc loc)        ; return (CtWanted { ctev_pred = pty, ctev_dest = EvVarDest new_ev-                          , ctev_nosh = WDeriv+                          , ctev_nosh = si                           , ctev_loc = loc })}  newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew+newWantedEvVar = newWantedEvVar_SI WDeriv++newWantedEvVar_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS MaybeNew -- For anything except ClassPred, this is the same as newWantedEvVarNC-newWantedEvVar loc pty+newWantedEvVar_SI si loc pty   = do { mb_ct <- lookupInInerts loc pty        ; case mb_ct of             Just ctev               | not (isDerived ctev)               -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev                     ; return $ Cached (ctEvExpr ctev) }-            _ -> do { ctev <- newWantedEvVarNC loc pty+            _ -> do { ctev <- newWantedEvVarNC_SI si loc pty                     ; return (Fresh ctev) } } --- deals with both equalities and non equalities. Tries to look--- up non-equalities in the cache newWanted :: CtLoc -> PredType -> TcS MaybeNew-newWanted loc pty+-- Deals with both equalities and non equalities. Tries to look+-- up non-equalities in the cache+newWanted = newWanted_SI WDeriv++newWanted_SI :: ShadowInfo -> CtLoc -> PredType -> TcS MaybeNew+newWanted_SI si loc pty   | Just (role, ty1, ty2) <- getEqPredTys_maybe pty-  = Fresh . fst <$> newWantedEq loc role ty1 ty2+  = Fresh . fst <$> newWantedEq_SI si loc role ty1 ty2   | otherwise-  = newWantedEvVar loc pty+  = newWantedEvVar_SI si loc pty  -- deals with both equalities and non equalities. Doesn't do any cache lookups. newWantedNC :: CtLoc -> PredType -> TcS CtEvidence@@ -3494,11 +3549,12 @@          wrapErrTcS $          solverDepthErrorTcS loc ty } -matchFam :: TyCon -> [Type] -> TcS (Maybe (Coercion, TcType))+matchFam :: TyCon -> [Type] -> TcS (Maybe (CoercionN, TcType))+-- Given (F tys) return (ty, co), where co :: F tys ~N ty matchFam tycon args = wrapTcS $ matchFamTcM tycon args -matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (Coercion, TcType))--- Given (F tys) return (ty, co), where co :: F tys ~ ty+matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (CoercionN, TcType))+-- Given (F tys) return (ty, co), where co :: F tys ~N ty matchFamTcM tycon args   = do { fam_envs <- FamInst.tcGetFamInstEnvs        ; let match_fam_result
compiler/typecheck/TcSigs.hs view
@@ -23,14 +23,15 @@        mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, addInlinePrags    ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude -import HsSyn+import GHC.Hs import TcHsType import TcRnTypes import TcRnMonad+import TcOrigin import TcType import TcMType import TcValidity ( checkValidType )@@ -45,7 +46,6 @@ import Id       ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId ) import PrelNames( mkUnboundName ) import BasicTypes-import Bag( foldrBag ) import Module( getModule ) import Name import NameEnv@@ -222,6 +222,7 @@ tcUserTypeSig loc hs_sig_ty mb_name   | isCompleteHsSig hs_sig_ty   = do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty+       ; traceTc "tcuser" (ppr sigma_ty)        ; return $          CompleteSig { sig_bndr  = mkLocalId name sigma_ty                      , sig_ctxt  = ctxt_T@@ -257,8 +258,8 @@ isCompleteHsSig (HsWC { hswc_ext  = wcs                       , hswc_body = HsIB { hsib_body = hs_ty } })    = null wcs && no_anon_wc hs_ty-isCompleteHsSig (HsWC _ (XHsImplicitBndrs _)) = panic "isCompleteHsSig"-isCompleteHsSig (XHsWildCardBndrs _) = panic "isCompleteHsSig"+isCompleteHsSig (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec+isCompleteHsSig (XHsWildCardBndrs nec) = noExtCon nec  no_anon_wc :: LHsType GhcRn -> Bool no_anon_wc lty = go lty@@ -299,7 +300,7 @@   where     go (UserTyVar _ _)      = True     go (KindedTyVar _ _ ki) = no_anon_wc ki-    go (XTyVarBndr{})       = panic "no_anon_wc_bndrs"+    go (XTyVarBndr nec)     = noExtCon nec  {- Note [Fail eagerly on bad signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -331,7 +332,7 @@  Note [Pattern synonym signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Pattern synonym signatures are surprisingly tricky (see Trac #11224 for example).+Pattern synonym signatures are surprisingly tricky (see #11224 for example). In general they look like this:     pattern P :: forall univ_tvs. req_theta@@ -357,7 +358,7 @@ synonym signature, because we are going to zonk the signature to a Type (not a TcType), in TcPatSyn.tc_patsyn_finish, and that fails if there are un-filled-in coercion variables mentioned-in the type (Trac #15694).+in the type (#15694).  The best thing is simply to use solveEqualities to solve all the equalites, rather than leaving them in the ambient constraints@@ -376,8 +377,8 @@ tcPatSynSig name sig_ty   | HsIB { hsib_ext = implicit_hs_tvs          , hsib_body = hs_ty }  <- sig_ty-  , (univ_hs_tvs, hs_req,  hs_ty1)     <- splitLHsSigmaTy hs_ty-  , (ex_hs_tvs,   hs_prov, hs_body_ty) <- splitLHsSigmaTy hs_ty1+  , (univ_hs_tvs, hs_req,  hs_ty1)     <- splitLHsSigmaTyInvis hs_ty+  , (ex_hs_tvs,   hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1   = do {  traceTc "tcPatSynSig 1" (ppr sig_ty)        ; (implicit_tvs, (univ_tvs, (ex_tvs, (req, prov, body_ty))))            <- pushTcLevelM_   $@@ -389,14 +390,14 @@                  ; prov    <- tcHsContext hs_prov                  ; body_ty <- tcHsOpenType hs_body_ty                      -- A (literal) pattern can be unlifted;-                     -- e.g. pattern Zero <- 0#   (Trac #12094)+                     -- e.g. pattern Zero <- 0#   (#12094)                  ; return (req, prov, body_ty) } -       ; let ungen_patsyn_ty = build_patsyn_type [] implicit_tvs univ_tvs req-                                                 ex_tvs prov body_ty+       ; let ungen_patsyn_ty = build_patsyn_type [] implicit_tvs univ_tvs+                                                 req ex_tvs prov body_ty         -- Kind generalisation-       ; kvs <- kindGeneralize ungen_patsyn_ty+       ; kvs <- kindGeneralizeAll ungen_patsyn_ty        ; traceTc "tcPatSynSig" (ppr ungen_patsyn_ty)         -- These are /signatures/ so we zonk to squeeze out any kind@@ -460,11 +461,11 @@     build_patsyn_type kvs imp univ req ex prov body       = mkInvForAllTys kvs $         mkSpecForAllTys (imp ++ univ) $-        mkFunTys req $+        mkPhiTy req $         mkSpecForAllTys ex $-        mkFunTys prov $+        mkPhiTy prov $         body-tcPatSynSig _ (XHsImplicitBndrs _) = panic "tcPatSynSig"+tcPatSynSig _ (XHsImplicitBndrs nec) = noExtCon nec  ppr_tvs :: [TyVar] -> SDoc ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv)@@ -497,25 +498,14 @@                              , sig_loc = loc })   = setSrcSpan loc $  -- Set the binding site of the tyvars     do { traceTc "Staring partial sig {" (ppr hs_sig)-       ; (wcs, wcx, tv_names, tvs, theta, tau) <- tcHsPartialSigType ctxt hs_ty--        -- Clone the quantified tyvars-        -- Reason: we might have    f, g :: forall a. a -> _ -> a-        --         and we want it to behave exactly as if there were-        --         two separate signatures.  Cloning here seems like-        --         the easiest way to do so, and is very similar to-        --         the tcInstType in the CompleteSig case-        -- See Trac #14643-       ; (subst, tvs') <- newMetaTyVarTyVars tvs-                         -- Why newMetaTyVarTyVars?  See TcBinds-                         -- Note [Quantified variables in partial type signatures]-       ; let tv_prs = tv_names `zip` tvs'-             inst_sig = TISI { sig_inst_sig   = hs_sig+       ; (wcs, wcx, tv_prs, theta, tau) <- tcHsPartialSigType ctxt hs_ty+         -- See Note [Checking partial type signatures] in TcHsType+       ; let inst_sig = TISI { sig_inst_sig   = hs_sig                              , sig_inst_skols = tv_prs                              , sig_inst_wcs   = wcs                              , sig_inst_wcx   = wcx-                             , sig_inst_theta = substTys subst theta-                             , sig_inst_tau   = substTy  subst tau }+                             , sig_inst_theta = theta+                             , sig_inst_tau   = tau }        ; traceTc "End partial sig }" (ppr inst_sig)        ; return inst_sig } @@ -587,7 +577,7 @@      -- ar_env maps a local to the arity of its definition     ar_env :: NameEnv Arity-    ar_env = foldrBag lhsBindArity emptyNameEnv binds+    ar_env = foldr lhsBindArity emptyNameEnv binds  lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env@@ -697,7 +687,7 @@    the "deeply" stuff may be too much, because it introduces lambdas,    though I think it can be made to work without too much trouble.) -2. We need to take care with type families (Trac #5821).  Consider+2. We need to take care with type families (#5821).  Consider       type instance F Int = Bool       f :: Num a => a -> F a       {-# SPECIALISE foo :: Int -> Bool #-}@@ -764,7 +754,7 @@ -- Example: SPECIALISE for a class method: the Name in the SpecSig is --          for the selector Id, but the poly_id is something like $cop -- However we want to use fun_name in the error message, since that is--- what the user wrote (Trac #8537)+-- what the user wrote (#8537)   = addErrCtxt (spec_ctxt prag) $     do  { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))                  (text "SPECIALISE pragma for non-overloaded function"@@ -776,7 +766,7 @@   where     name      = idName poly_id     poly_ty   = idType poly_id-    spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag)+    spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag)      tc_one hs_ty       = do { spec_ty <- tcHsSigType   (FunSigCtxt name False) hs_ty
compiler/typecheck/TcSimplify.hs view
@@ -24,16 +24,14 @@        approximateWC, runTcSDeriveds   ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import Bag import Class         ( Class, classKey, classTyCon )-import DynFlags      ( WarningFlag ( Opt_WarnMonomorphism )-                     , WarnReason ( Reason )-                     , DynFlags( solverIterations ) )-import HsExpr        ( UnboundVar(..) )+import DynFlags+import GHC.Hs.Expr   ( UnboundVar(..) ) import Id            ( idType, mkLocalId ) import Inst import ListSetOps@@ -49,8 +47,10 @@ import TcMType   as TcM import TcRnMonad as TcM import TcSMonad  as TcS+import Constraint+import Predicate+import TcOrigin import TcType-import TrieMap       () -- DV: for now import Type import TysWiredIn    ( liftedRepTy ) import Unify         ( tcMatchTyKi )@@ -81,8 +81,21 @@ -- generates plus the constraints produced by static forms inside. -- If it fails with an exception, it reports any insolubles -- (out of scope variables) before doing so--- NB: bring any environments into scope before calling this, so that--- the reportUnsolved has access to the most complete GlobalRdrEnv+--+-- captureTopConstraints is used exclusively by TcRnDriver at the top+-- level of a module.+--+-- Importantly, if captureTopConstraints propagates an exception, it+-- reports any insoluble constraints first, lest they be lost+-- altogether.  This is important, because solveLocalEqualities (maybe+-- other things too) throws an exception without adding any error+-- messages; it just puts the unsolved constraints back into the+-- monad. See TcRnMonad Note [Constraints and errors]+-- #16376 is an example of what goes wrong if you don't do this.+--+-- NB: the caller should bring any environments into scope before+-- calling this, so that the reportUnsolved has access to the most+-- complete GlobalRdrEnv captureTopConstraints thing_inside   = do { static_wc_var <- TcM.newTcRef emptyWC ;        ; (mb_res, lie) <- TcM.updGblEnv (\env -> env { tcg_static_wc = static_wc_var } ) $@@ -216,12 +229,16 @@ simpl_top wanteds   = do { wc_first_go <- nestTcS (solveWantedsAndDrop wanteds)                             -- This is where the main work happens-       ; try_tyvar_defaulting wc_first_go }+       ; dflags <- getDynFlags+       ; try_tyvar_defaulting dflags wc_first_go }   where-    try_tyvar_defaulting :: WantedConstraints -> TcS WantedConstraints-    try_tyvar_defaulting wc+    try_tyvar_defaulting :: DynFlags -> WantedConstraints -> TcS WantedConstraints+    try_tyvar_defaulting dflags wc       | isEmptyWC wc       = return wc+      | insolubleWC wc+      , gopt Opt_PrintExplicitRuntimeReps dflags -- See Note [Defaulting insolubles]+      = try_class_defaulting wc       | otherwise       = do { free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc)            ; let meta_tvs = filter (isTyVar <&&> isMetaTyVar) free_tvs@@ -239,7 +256,7 @@      try_class_defaulting :: WantedConstraints -> TcS WantedConstraints     try_class_defaulting wc-      | isEmptyWC wc+      | isEmptyWC wc || insolubleWC wc -- See Note [Defaulting insolubles]       = return wc       | otherwise  -- See Note [When to do type-class defaulting]       = do { something_happened <- applyDefaultingRules wc@@ -311,7 +328,7 @@            <type> |> co-hole     where co-hole is not filled in.  Eeek!  That un-filled-in     hole actually causes GHC to crash with "fvProv falls into a hole"-    See Trac #11563, #11520, #11516, #11399+    See #11563, #11520, #11516, #11399  So it's important to use 'checkNoErrs' here! @@ -323,12 +340,12 @@ lot of errors that would be solved by defaulting; these errors are quite spurious because fixing the single insoluble error means that defaulting happens again, which makes all the other errors go away.-This is jolly confusing: Trac #9033.+This is jolly confusing: #9033.  So it seems better to always do type-class defaulting.  However, always doing defaulting does mean that we'll do it in-situations like this (Trac #5934):+situations like this (#5934):    run :: (forall s. GenST s) -> Int    run = fromInteger 0 We don't unify the return type of fromInteger with the given function@@ -349,7 +366,7 @@ which we couldn't solve because of the kind incompatibility, and 'a' is free. Then when we default 'a' we can solve the constraint.  And we want to do that before starting in on type classes.  We MUST do it before reporting-errors, because it isn't an error!  Trac #7967 was due to this.+errors, because it isn't an error!  #7967 was due to this.  Note [Top-level Defaulting Plan] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -500,11 +517,55 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When simplifying constraints for the ambiguity check, we use solveWantedsAndDrop, not simpl_top, so that we do no defaulting.-Trac #11947 was an example:+#11947 was an example:    f :: Num a => Int -> Int This is ambiguous of course, but we don't want to default the (Num alpha) constraint to (Num Int)!  Doing so gives a defaulting warning, but no error.++Note [Defaulting insolubles]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a set of wanteds is insoluble, we have no hope of accepting the+program. Yet we do not stop constraint solving, etc., because we may+simplify the wanteds to produce better error messages. So, once+we have an insoluble constraint, everything we do is just about producing+helpful error messages.++Should we default in this case or not? Let's look at an example (tcfail004):++  (f,g) = (1,2,3)++With defaulting, we get a conflict between (a0,b0) and (Integer,Integer,Integer).+Without defaulting, we get a conflict between (a0,b0) and (a1,b1,c1). I (Richard)+find the latter more helpful. Several other test cases (e.g. tcfail005) suggest+similarly. So: we should not do class defaulting with insolubles.++On the other hand, RuntimeRep-defaulting is different. Witness tcfail078:++  f :: Integer i => i+  f =               0++Without RuntimeRep-defaulting, we GHC suggests that Integer should have kind+TYPE r0 -> Constraint and then complains that r0 is actually untouchable+(presumably, because it can't be sure if `Integer i` entails an equality).+If we default, we are told of a clash between (* -> Constraint) and Constraint.+The latter seems far better, suggesting we *should* do RuntimeRep-defaulting+even on insolubles.++But, evidently, not always. Witness UnliftedNewtypesInfinite:++  newtype Foo = FooC (# Int#, Foo #)++This should fail with an occurs-check error on the kind of Foo (with -XUnliftedNewtypes).+If we default RuntimeRep-vars, we get++  Expecting a lifted type, but ‘(# Int#, Foo #)’ is unlifted++which is just plain wrong.++Conclusion: we should do RuntimeRep-defaulting on insolubles only when the user does not+want to hear about RuntimeRep stuff -- that is, when -fprint-explicit-runtime-reps+is not set. -}  ------------------@@ -613,11 +674,11 @@ find superclasses, using try_harder.  Reason: we might have a type signature    f :: F op (Implements push) => ..-where F is a type function.  This happened in Trac #3972.+where F is a type function.  This happened in #3972.  We could do more than once but we'd have to have /some/ limit: in the the recursive case, we would go on forever in the common case where-the constraints /are/ satisfiable (Trac #10592 comment:12!).+the constraints /are/ satisfiable (#10592 comment:12!).  For stratightforard situations without type functions the try_harder step does nothing.@@ -630,10 +691,12 @@ the purpose of tcNormalise is to take a type, plus some local constraints, and normalise the type as much as possible with respect to those constraints. +It does *not* reduce type or data family applications or look through newtypes.+ Why is this useful? As one example, when coverage-checking an EmptyCase expression, it's possible that the type of the scrutinee will only reduce if some local equalities are solved for. See "Wrinkle: Local equalities"-in Note [Type normalisation for EmptyCase] in Check.+in Note [Type normalisation] in Check.  To accomplish its stated goal, tcNormalise first feeds the local constraints into solveSimpleGivens, then stuffs the argument type in a CHoleCan, and feeds@@ -704,9 +767,8 @@               psig_theta  = [ pred | sig <- partial_sigs                                    , pred <- sig_inst_theta sig ] -       ; gbl_tvs <- tcGetGlobalTyCoVars        ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus)-       ; qtkvs <- quantifyTyVars gbl_tvs dep_vars+       ; qtkvs <- quantifyTyVars dep_vars        ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs)        ; return (qtkvs, [], emptyTcEvBinds, emptyWC, False) } @@ -770,7 +832,7 @@         -- We must produce bindings for the psig_theta_vars, because we may have        -- used them in evidence bindings constructed by solveWanteds earlier-       -- Easiest way to do this is to emit them as new Wanteds (Trac #14643)+       -- Easiest way to do this is to emit them as new Wanteds (#14643)        ; ct_loc <- getCtLocM AnnOrigin Nothing        ; let psig_wanted = [ CtWanted { ctev_pred = idType psig_theta_var                                       , ctev_dest = EvVarDest psig_theta_var@@ -779,7 +841,7 @@                            | psig_theta_var <- psig_theta_vars ]         -- Now construct the residual constraint-       ; residual_wanted <- mkResidualConstraints rhs_tclvl tc_env ev_binds_var+       ; residual_wanted <- mkResidualConstraints rhs_tclvl ev_binds_var                                  name_taus co_vars qtvs bound_theta_vars                                  (wanted_transformed `andWC` mkSimpleWC psig_wanted) @@ -798,13 +860,13 @@     partial_sigs = filter isPartialSig sigs  ---------------------mkResidualConstraints :: TcLevel -> Env TcGblEnv TcLclEnv -> EvBindsVar+mkResidualConstraints :: TcLevel -> EvBindsVar                       -> [(Name, TcTauType)]                       -> VarSet -> [TcTyVar] -> [EvVar]                       -> WantedConstraints -> TcM WantedConstraints -- Emit the remaining constraints from the RHS. -- See Note [Emitting the residual implication in simplifyInfer]-mkResidualConstraints rhs_tclvl tc_env ev_binds_var+mkResidualConstraints rhs_tclvl ev_binds_var                         name_taus co_vars qtvs full_theta_vars wanteds   | isEmptyWC wanteds   = return wanteds@@ -817,23 +879,22 @@         ; _ <- promoteTyVarSet (tyCoVarsOfCts outer_simple)          ; let inner_wanted = wanteds { wc_simple = inner_simple }+        ; implics <- if isEmptyWC inner_wanted+                     then return emptyBag+                     else do implic1 <- newImplication+                             return $ unitBag $+                                      implic1  { ic_tclvl  = rhs_tclvl+                                               , ic_skols  = qtvs+                                               , ic_telescope = Nothing+                                               , ic_given  = full_theta_vars+                                               , ic_wanted = inner_wanted+                                               , ic_binds  = ev_binds_var+                                               , ic_no_eqs = False+                                               , ic_info   = skol_info }+         ; return (WC { wc_simple = outer_simple-                     , wc_impl   = mk_implic inner_wanted })}+                     , wc_impl   = implics })}   where-    mk_implic inner_wanted-      | isEmptyWC inner_wanted-      = emptyBag-      | otherwise-      = unitBag (implicationPrototype { ic_tclvl  = rhs_tclvl-                                      , ic_skols  = qtvs-                                      , ic_telescope = Nothing-                                      , ic_given  = full_theta_vars-                                      , ic_wanted = inner_wanted-                                      , ic_binds  = ev_binds_var-                                      , ic_no_eqs = False-                                      , ic_info   = skol_info-                                      , ic_env    = tc_env })-     full_theta = map idType full_theta_vars     skol_info  = InferSkol [ (name, mkSigmaTy [] full_theta ty)                            | (name, ty) <- name_taus ]@@ -870,11 +931,11 @@ which takes the CoVars free in the inferred type, and pulls their constraints out.  (NB: this set of CoVars should be closed-over-kinds.) -All rather subtle; see Trac #14584.+All rather subtle; see #14584.  Note [Add signature contexts as givens] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (Trac #11016):+Consider this (#11016):   f2 :: (?x :: Int) => _   f2 = ?x or this@@ -924,7 +985,7 @@   not going to become further constrained), and re-simplify the   candidate constraints. -  Motivation for re-simplification (Trac #7857): imagine we have a+  Motivation for re-simplification (#7857): imagine we have a   constraint (C (a->b)), where 'a :: TYPE l1' and 'b :: TYPE l2' are   not free in the envt, and instance forall (a::*) (b::*). (C a) => C   (a -> b) The instance doesn't match while l1,l2 are polymorphic, but@@ -969,7 +1030,7 @@        ; candidates <- defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates         -- Step 3: decide which kind/type variables to quantify over-       ; qtvs <- decideQuantifiedTyVars mono_tvs name_taus psigs candidates+       ; qtvs <- decideQuantifiedTyVars name_taus psigs candidates         -- Step 4: choose which of the remaining candidate        --         predicates to actually quantify over@@ -981,7 +1042,7 @@                = pickQuantifiablePreds (mkVarSet qtvs) candidates              -- NB: do /not/ run pickQuantifiablePreds over psig_theta,              -- because we always want to quantify over psig_theta, and not-             -- drop any of them; e.g. CallStack constraints.  c.f Trac #14658+             -- drop any of them; e.g. CallStack constraints.  c.f #14658               theta = mkMinimalBySCs id $  -- See Note [Minimize by Superclasses]                      (psig_theta ++ quantifiable_candidates)@@ -1021,7 +1082,7 @@         ; taus <- mapM (TcM.zonkTcType . snd) name_taus -       ; mono_tvs0 <- tcGetGlobalTyCoVars+       ; tc_lvl <- TcM.getTcLevel        ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta               co_vars = coVarsOfTypes (psig_tys ++ taus)@@ -1032,27 +1093,42 @@                -- E.g.  If we can't quantify over co :: k~Type, then we can't                --       quantify over k either!  Hence closeOverKinds +             mono_tvs0 = filterVarSet (not . isQuantifiableTv tc_lvl) $+                         tyCoVarsOfTypes candidates+               -- We need to grab all the non-quantifiable tyvars in the+               -- candidates so that we can grow this set to find other+               -- non-quantifiable tyvars. This can happen with something+               -- like+               --    f x y = ...+               --      where z = x 3+               -- The body of z tries to unify the type of x (call it alpha[1])+               -- with (beta[2] -> gamma[2]). This unification fails because+               -- alpha is untouchable. But we need to know not to quantify over+               -- beta or gamma, because they are in the equality constraint with+               -- alpha. Actual test case: typecheck/should_compile/tc213+              mono_tvs1 = mono_tvs0 `unionVarSet` co_var_tvs -             eq_constraints = filter isEqPred candidates+             eq_constraints = filter isEqPrimPred candidates              mono_tvs2      = growThetaTyVars eq_constraints mono_tvs1 -             constrained_tvs = (growThetaTyVars eq_constraints+             constrained_tvs = filterVarSet (isQuantifiableTv tc_lvl) $+                               (growThetaTyVars eq_constraints                                                (tyCoVarsOfTypes no_quant)                                 `minusVarSet` mono_tvs2)                                `delVarSetList` psig_qtvs              -- constrained_tvs: the tyvars that we are not going to-             -- quantify solely because of the moonomorphism restriction+             -- quantify solely because of the monomorphism restriction              ---             -- (`minusVarSet` mono_tvs1`): a type variable is only+             -- (`minusVarSet` mono_tvs2`): a type variable is only              --   "constrained" (so that the MR bites) if it is not-             --   free in the environment (Trac #13785)+             --   free in the environment (#13785)              --              -- (`delVarSetList` psig_qtvs): if the user has explicitly              --   asked for quantification, then that request "wins"              --   over the MR.  Note: do /not/ delete psig_qtvs from              --   mono_tvs1, because mono_tvs1 cannot under any circumstances-             --   be quantified (Trac #14479); see+             --   be quantified (#14479); see              --   Note [Quantification and partial signatures], Wrinkle 3, 4               mono_tvs = mono_tvs2 `unionVarSet` constrained_tvs@@ -1066,7 +1142,6 @@         ; traceTc "decideMonoTyVars" $ vcat            [ text "mono_tvs0 =" <+> ppr mono_tvs0-           , text "mono_tvs1 =" <+> ppr mono_tvs1            , text "no_quant =" <+> ppr no_quant            , text "maybe_quant =" <+> ppr maybe_quant            , text "eq_constraints =" <+> ppr eq_constraints@@ -1155,13 +1230,12 @@  ------------------ decideQuantifiedTyVars-   :: TyCoVarSet        -- Monomorphic tyvars-   -> [(Name,TcType)]   -- Annotated theta and (name,tau) pairs+   :: [(Name,TcType)]   -- Annotated theta and (name,tau) pairs    -> [TcIdSigInst]     -- Partial signatures    -> [PredType]        -- Candidates, zonked    -> TcM [TyVar] -- Fix what tyvars we are going to quantify over, and quantify them-decideQuantifiedTyVars mono_tvs name_taus psigs candidates+decideQuantifiedTyVars name_taus psigs candidates   = do {     -- Why psig_tys? We try to quantify over everything free in here              -- See Note [Quantification and partial signatures]              --     Wrinkles 2 and 3@@ -1170,7 +1244,6 @@        ; psig_theta <- mapM TcM.zonkTcType [ pred | sig <- psigs                                                   , pred <- sig_inst_theta sig ]        ; tau_tys  <- mapM (TcM.zonkTcType . snd) name_taus-       ; mono_tvs <- TcM.zonkTyCoVarsAndFV mono_tvs         ; let -- Try to quantify over variables free in these types              psig_tys = psig_tv_tys ++ psig_theta@@ -1184,7 +1257,7 @@        --        -- Keep the psig_tys first, so that candidateQTyVarsOfTypes produces        -- them in that order, so that the final qtvs quantifies in the same-       -- order as the partial signatures do (Trac #13524)+       -- order as the partial signatures do (#13524)        ; dv@DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} <- candidateQTyVarsOfTypes $                                                          psig_tys ++ candidates ++ tau_tys        ; let pick     = (`dVarSetIntersectVarSet` grown_tcvs)@@ -1198,7 +1271,7 @@            , text "grown_tcvs =" <+> ppr grown_tcvs            , text "dvs =" <+> ppr dvs_plus]) -       ; quantifyTyVars mono_tvs dvs_plus }+       ; quantifyTyVars dvs_plus }  ------------------ growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet@@ -1280,14 +1353,14 @@   Bottom line: Try to quantify over any variable free in psig_theta,   just like the tau-part of the type. -* Wrinkle 3 (Trac #13482). Also consider+* Wrinkle 3 (#13482). Also consider     f :: forall a. _ => Int -> Int     f x = if (undefined :: a) == undefined then x else 0   Here we get an (Eq a) constraint, but it's not mentioned in the   psig_theta nor the type of 'f'.  But we still want to quantify   over 'a' even if the monomorphism restriction is on. -* Wrinkle 4 (Trac #14479)+* Wrinkle 4 (#14479)     foo :: Num a => a -> a     foo xxx = g xxx       where@@ -1330,7 +1403,7 @@     - Avoid downstream errors     - Do not perform an ambiguity test on a bogus type, which might well       fail spuriously, thereby obfuscating the original insoluble error.-      Trac #14000 is an example+      #14000 is an example  I tried an alternative approach: simply failM, after emitting the residual implication constraint; the exception will be caught in@@ -1343,7 +1416,7 @@ Example:     (a::*) ~ Int# We get an insoluble derived error *~#, and we don't want to discard-it before doing the isInsolubleWC test!  (Trac #8262)+it before doing the isInsolubleWC test!  (#8262)  Note [Default while Inferring] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1395,7 +1468,7 @@ Note [Avoid unnecessary constraint simplification] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~     -------- NB NB NB (Jun 12) --------------    This note not longer applies; see the notes with Trac #4361.+    This note not longer applies; see the notes with #4361.     But I'm leaving it in here so we remember the issue.)     ---------------------------------------- When inferring the type of a let-binding, with simplifyInfer,@@ -1595,7 +1668,7 @@          -- Solve the nested constraints        ; (no_given_eqs, given_insols, residual_wanted)             <- nestImplicTcS ev_binds_var tclvl $-               do { let loc    = mkGivenLoc tclvl info (implicLclEnv imp)+               do { let loc    = mkGivenLoc tclvl info (ic_env imp)                         givens = mkGivens loc given_ids                   ; solveSimpleGivens givens @@ -1758,7 +1831,7 @@        _                           -> False    -- To think about: do we want to report redundant givens for-  -- pattern synonyms, PatSynSigSkol? c.f Trac #9953, comment:21.+  -- pattern synonyms, PatSynSigSkol? c.f #9953, comment:21. warnRedundantGivens (InstSkol {}) = True warnRedundantGivens _             = False @@ -1791,7 +1864,7 @@  = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var       ; tcvs     <- TcS.getTcEvTyCoVars ev_binds_var -      ; let seeds1        = foldrBag add_implic_seeds old_needs implics+      ; let seeds1        = foldr add_implic_seeds old_needs implics             seeds2        = foldEvBindMap add_wanted seeds1 ev_binds             seeds3        = seeds2 `unionVarSet` tcvs             need_inner    = findNeededEvVars ev_binds seeds3@@ -1844,7 +1917,7 @@ such dead superclass selections will eventually be dropped as dead code, but: - * It won't always be dropped (Trac #13032).  In the case of an+ * It won't always be dropped (#13032).  In the case of an    unlifted-equality superclass like d2 above, we generate        case heq_sc d1 of d2 -> ...    and we can't (in general) drop that case exrpession in case@@ -1867,7 +1940,7 @@ test T12227.  But we don't get to discard all redundant equality superclasses, alas;-see Trac #15205.+see #15205.  Note [Tracking redundant constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1959,7 +2032,7 @@  ----- Shortcomings -Consider (see Trac #9939)+Consider (see #9939)     f2 :: (Eq a, Ord a) => a -> a -> Bool     -- Ord a redundant, but Eq a is reported     f2 x y = (x == y)@@ -1971,7 +2044,7 @@ Note [Cutting off simpl_loop] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It is very important not to iterate in simpl_loop unless there is a chance-of progress.  Trac #8474 is a classic example:+of progress.  #8474 is a classic example:    * There's a deeply-nested chain of implication constraints.        ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int@@ -2069,7 +2142,7 @@         new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp      do_bag :: (a -> Bag c) -> Bag a -> Bag c-    do_bag f = foldrBag (unionBags.f) emptyBag+    do_bag f = foldr (unionBags.f) emptyBag      is_floatable skol_tvs ct        | isGivenCt ct     = False@@ -2107,12 +2180,12 @@     float out of such implications, which meant it would happily infer     non-principal types.) -   HOWEVER (Trac #12797) in findDefaultableGroups we are not worried about+   HOWEVER (#12797) in findDefaultableGroups we are not worried about    the most-general type; and we /do/ want to float out of equalities.    Hence the boolean flag to approximateWC.  ------ Historical note ------------There used to be a second caveat, driven by Trac #8155+There used to be a second caveat, driven by #8155     2. We do not float out an inner constraint that shares a type variable       (transitively) with one that is trapped by a skolem.  Eg@@ -2131,7 +2204,7 @@  But this transitive closure stuff gives rise to a complex rule for when defaulting actually happens, and one that was never documented.-Moreover (Trac #12923), the more complex rule is sometimes NOT what+Moreover (#12923), the more complex rule is sometimes NOT what you want.  So I simply removed the extra code to implement the contamination stuff.  There was zero effect on the testsuite (not even #8155).@@ -2175,8 +2248,8 @@ have an instance (C ((x:*) -> Int)).  The instance doesn't match -- but it should!  If we don't solve the constraint, we'll stupidly quantify over (C (a->Int)) and, worse, in doing so skolemiseQuantifiedTyVar will quantify over-(b:*) instead of (a:OpenKind), which can lead to disaster; see Trac #7332.-Trac #7641 is a simpler example.+(b:*) instead of (a:OpenKind), which can lead to disaster; see #7332.+#7641 is a simpler example.  Note [Promoting unification variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2310,7 +2383,7 @@               seed_skols = mkVarSet skols     `unionVarSet`                           mkVarSet given_ids `unionVarSet`-                          foldrBag add_non_flt_ct emptyVarSet no_float_cts `unionVarSet`+                          foldr add_non_flt_ct emptyVarSet no_float_cts `unionVarSet`                           foldEvBindMap add_one_bind emptyVarSet binds              -- seed_skols: See Note [What prevents a constraint from floating] (1,2,3)              -- Include the EvIds of any non-floating constraints@@ -2349,7 +2422,7 @@       | otherwise      = not (ctEvId ct `elemVarSet` skols)      add_captured_ev_ids :: Cts -> VarSet -> VarSet-    add_captured_ev_ids cts skols = foldrBag extra_skol emptyVarSet cts+    add_captured_ev_ids cts skols = foldr extra_skol emptyVarSet cts        where          extra_skol ct acc            | isDerivedCt ct                           = acc@@ -2472,7 +2545,7 @@ (4) is done by the transCloVarSet call.  The possible dependence on givens, and evidence bindings, is more-subtle than we'd realised at first.  See Trac #14584.+subtle than we'd realised at first.  See #14584.   *********************************************************************************@@ -2531,7 +2604,7 @@          -- Finds unary type-class constraints         -- But take account of polykinded classes like Typeable,-        -- which may look like (Typeable * (a:*))   (Trac #8931)+        -- which may look like (Typeable * (a:*))   (#8931)     find_unary :: Ct -> Either (Ct, Class, TyVar) Ct     find_unary cc         | Just (cls,tys)   <- getClassPredTys_maybe (ctPred cc)
compiler/typecheck/TcSplice.hs view
@@ -29,11 +29,11 @@      finishTH, runTopSplice       ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude -import HsSyn+import GHC.Hs import Annotations import Finder import Name@@ -46,6 +46,7 @@ import THNames import TcUnify import TcEnv+import TcOrigin import Coercion( etaExpandCoAxBranch ) import FileCleanup ( newTempName, TempFileLifetime(..) ) @@ -60,7 +61,7 @@ import RnSplice( traceSplice, SpliceInfo(..)) import RdrName import HscTypes-import Convert+import GHC.ThToHs import RnExpr import RnEnv import RnUtils ( HsDocContext(..) )@@ -177,14 +178,15 @@        ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $                                 tcInferRhoNC expr                                 -- NC for no context; tcBracket does that+       ; let rep = getRuntimeRep expr_ty         ; meta_ty <- tcTExpTy expr_ty        ; ps' <- readMutVar ps_ref        ; texpco <- tcLookupId unsafeTExpCoerceName        ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr")                        rn_expr-                       (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty])-                                      (noLoc (HsTcBracketOut noExt brack ps'))))+                       (unLoc (mkHsApp (nlHsTyApp texpco [rep, expr_ty])+                                      (noLoc (HsTcBracketOut noExtField brack ps'))))                        meta_ty res_ty } tcTypedBracket _ other_brack _   = pprPanic "tcTypedBracket" (ppr other_brack)@@ -196,7 +198,7 @@        ; meta_ty <- tcBrackTy brack        ; traceTc "tc_bracket done untyped" (ppr meta_ty)        ; tcWrapResultO (Shouldn'tHappenOrigin "untyped bracket")-                       rn_expr (HsTcBracketOut noExt brack ps') meta_ty res_ty }+                       rn_expr (HsTcBracketOut noExtField brack ps') meta_ty res_ty }  --------------- tcBrackTy :: HsBracket GhcRn -> TcM TcType@@ -206,9 +208,9 @@ tcBrackTy (TypBr {})  = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ) tcBrackTy (DecBrG {}) = tcMetaTy decsQTyConName -- Result type is Q [Dec] tcBrackTy (PatBr {})  = tcMetaTy patQTyConName  -- Result type is PatQ (= Q Pat)-tcBrackTy (DecBrL {})   = panic "tcBrackTy: Unexpected DecBrL"-tcBrackTy (TExpBr {})   = panic "tcUntypedBracket: Unexpected TExpBr"-tcBrackTy (XBracket {}) = panic "tcUntypedBracket: Unexpected XBracket"+tcBrackTy (DecBrL {}) = panic "tcBrackTy: Unexpected DecBrL"+tcBrackTy (TExpBr {}) = panic "tcUntypedBracket: Unexpected TExpBr"+tcBrackTy (XBracket nec) = noExtCon nec  --------------- tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice@@ -230,7 +232,8 @@   = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty)        ; q    <- tcLookupTyCon qTyConName        ; texp <- tcLookupTyCon tExpTyConName-       ; return (mkTyConApp q [mkTyConApp texp [exp_ty]]) }+       ; let rep = getRuntimeRep exp_ty+       ; return (mkTyConApp q [mkTyConApp texp [rep, exp_ty]]) }   where     err_msg ty       = vcat [ text "Illegal polytype:" <+> ppr ty@@ -254,7 +257,7 @@   1. tcTopSpliceExpr: typecheck the body e of the splice $(e)    2. runMetaT: desugar, compile, run it, and convert result back to-     HsSyn RdrName (of the appropriate flavour, eg HsType RdrName,+     GHC.Hs syntax RdrName (of the appropriate flavour, eg HsType RdrName,      HsExpr RdrName etc)    3. treat the result as if that's what you saw in the first place@@ -428,6 +431,39 @@  -} +-- | We only want to produce warnings for TH-splices if the user requests so.+-- See Note [Warnings for TH splices].+getThSpliceOrigin :: TcM Origin+getThSpliceOrigin = do+  warn <- goptM Opt_EnableThSpliceWarnings+  if warn then return FromSource else return Generated++{- Note [Warnings for TH splices]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We only produce warnings for TH splices when the user requests so+(-fenable-th-splice-warnings). There are multiple reasons:++  * It's not clear that the user that compiles a splice is the author of the code+    that produces the warning. Think of the situation where she just splices in+    code from a third-party library that produces incomplete pattern matches.+    In this scenario, the user isn't even able to fix that warning.+  * Gathering information for producing the warnings (pattern-match check+    warnings in particular) is costly. There's no point in doing so if the user+    is not interested in those warnings.++That's why we store Origin flags in the Haskell AST. The functions from ThToHs+take such a flag and depending on whether TH splice warnings were enabled or+not, we pass FromSource (if the user requests warnings) or Generated+(otherwise). This is implemented in getThSpliceOrigin.++For correct pattern-match warnings it's crucial that we annotate the Origin+consistently (#17270). In the future we could offer the Origin as part of the+TH AST. That would enable us to give quotes from the current module get+FromSource origin, and/or third library authors to tag certain parts of+generated code as FromSource to enable warnings. That effort is tracked in+#14838.+-}+ {- ************************************************************************ *                                                                      *@@ -469,12 +505,13 @@     -- A splice inside brackets tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty   = do { res_ty <- expTypeToType res_ty+       ; let rep = getRuntimeRep res_ty        ; meta_exp_ty <- tcTExpTy res_ty        ; expr' <- setStage pop_stage $                   setConstraintVar lie_var $                   tcMonoExpr expr (mkCheckExpType meta_exp_ty)        ; untypeq <- tcLookupId unTypeQName-       ; let expr'' = mkHsApp (nlHsTyApp untypeq [res_ty]) expr'+       ; let expr'' = mkHsApp (nlHsTyApp untypeq [rep, res_ty]) expr'        ; ps <- readMutVar ps_var        ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps) @@ -495,7 +532,7 @@        ; lcl_env <- getLclEnv        ; let delayed_splice               = DelayedSplice lcl_env expr res_ty q_expr-       ; return (HsSpliceE noExt (HsSplicedT delayed_splice))+       ; return (HsSpliceE noExtField (HsSplicedT delayed_splice))         } @@ -572,7 +609,7 @@                    -- going to run this code, but we do an unsafe                    -- coerce, so we get a seg-fault if, say we                    -- splice a type into a place where an expression-                   -- is expected (Trac #7276)+                   -- is expected (#7276)     setStage (Splice isTypedSplice) $     do {    -- Typecheck the expression          (expr', wanted) <- captureConstraints tc_action@@ -607,8 +644,8 @@               ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]               ; let specialised_to_annotation_wrapper_expr                       = L loc (mkHsWrap wrapper-                                 (HsVar noExt (L loc to_annotation_wrapper_id)))-              ; return (L loc (HsApp noExt+                                 (HsVar noExtField (L loc to_annotation_wrapper_id)))+              ; return (L loc (HsApp noExtField                                 specialised_to_annotation_wrapper_expr expr'))                                 }) @@ -682,15 +719,16 @@  runQResult   :: (a -> String)-  -> (SrcSpan -> a -> b)+  -> (Origin -> SrcSpan -> a -> b)   -> (ForeignHValue -> TcM a)   -> SrcSpan   -> ForeignHValue {- TH.Q a -}   -> TcM b runQResult show_th f runQ expr_span hval   = do { th_result <- runQ hval+       ; th_origin <- getThSpliceOrigin        ; traceTc "Got TH result:" (text (show_th th_result))-       ; return (f expr_span th_result) }+       ; return (f th_origin expr_span th_result) }   -----------------@@ -753,7 +791,7 @@         -- recovered giving it type f :: forall a.a, it'd be very dodgy         -- to carry ont.  Mind you, the staging restrictions mean we won't         -- actually run f, but it still seems wrong. And, more concretely,-        -- see Trac #5358 for an example that fell over when trying to+        -- see #5358 for an example that fell over when trying to         -- reify a function with a "?" kind in it.  (These don't occur         -- in type-correct programs.         ; failIfErrsM@@ -888,7 +926,7 @@   * 'qReport' forces the message to ensure any exception hidden in unevaluated    thunk doesn't get into the bag of errors. Otherwise the following splice-   will triger panic (Trac #8987):+   will triger panic (#8987):         $(fail undefined)    See also Note [Concealed TH exceptions] @@ -919,7 +957,7 @@  instance TH.Quasi TcM where   qNewName s = do { u <- newUnique-                  ; let i = getKey u+                  ; let i = toInteger (getKey u)                   ; return (TH.mkNameU s i) }    -- 'msg' is forced to ensure exceptions don't escape,@@ -942,6 +980,7 @@   qLookupName       = lookupName   qReify            = reify   qReifyFixity nm   = lookupThName nm >>= reifyFixity+  qReifyType        = reifyTypeOfThing   qReifyInstances   = reifyInstances   qReifyRoles       = reifyRoles   qReifyAnnotations = reifyAnnotations@@ -967,7 +1006,8 @@    qAddTopDecls thds = do       l <- getSrcSpanM-      let either_hval = convertToHsDecls l thds+      th_origin <- getThSpliceOrigin+      let either_hval = convertToHsDecls th_origin l thds       ds <- case either_hval of               Left exn -> failWithTc $                 hang (text "Error in a declaration passed to addTopDecls:")@@ -1207,6 +1247,7 @@   LookupName b str -> wrapTHResult $ TH.qLookupName b str   Reify n -> wrapTHResult $ TH.qReify n   ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n+  ReifyType n -> wrapTHResult $ TH.qReifyType n   ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts   ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n   ReifyAnnotations lookup tyrep ->@@ -1249,10 +1290,11 @@    = addErrCtxt (text "In the argument of reifyInstances:"                  <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $      do { loc <- getSrcSpanM-        ; rdr_ty <- cvt loc (mkThAppTs (TH.ConT th_nm) th_tys)+        ; th_origin <- getThSpliceOrigin+        ; rdr_ty <- cvt th_origin loc (mkThAppTs (TH.ConT th_nm) th_tys)           -- #9262 says to bring vars into scope, like in HsForAllTy case           -- of rnHsTyKi-        ; let tv_rdrs = freeKiTyVarsAllVars (extractHsTyRdrTyVars rdr_ty)+        ; let tv_rdrs = extractHsTyRdrTyVars rdr_ty           -- Rename  to HsType Name         ; ((tv_names, rn_ty), _fvs)             <- checkNoErrs $ -- If there are out-of-scope Names here, then we@@ -1270,11 +1312,11 @@         ; ty <- zonkTcTypeToType ty                 -- Substitute out the meta type variables                 -- In particular, the type might have kind-                -- variables inside it (Trac #7477)+                -- variables inside it (#7477)          ; traceTc "reifyInstances" (ppr ty $$ ppr (tcTypeKind ty))         ; case splitTyConApp_maybe ty of   -- This expands any type synonyms-            Just (tc, tys)                 -- See Trac #7910+            Just (tc, tys)                 -- See #7910                | Just cls <- tyConClass_maybe tc                -> do { inst_envs <- tcGetInstEnvs                      ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys@@ -1291,10 +1333,10 @@     doc = ClassInstanceCtx     bale_out msg = failWithTc msg -    cvt :: SrcSpan -> TH.Type -> TcM (LHsType GhcPs)-    cvt loc th_ty = case convertToHsType loc th_ty of-                      Left msg -> failWithTc msg-                      Right ty -> return ty+    cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs)+    cvt origin loc th_ty = case convertToHsType origin loc th_ty of+      Left msg -> failWithTc msg+      Right ty -> return ty  {- ************************************************************************@@ -1488,7 +1530,8 @@   = return (TH.PrimTyConI (reifyName tc) 2                False)    | isPrimTyCon tc-  = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnliftedTyCon tc))+  = return (TH.PrimTyConI (reifyName tc) (length (tyConVisibleTyVars tc))+                          (isUnliftedTyCon tc))    | isTypeFamilyTyCon tc   = do { let tvs      = tyConTyVars tc@@ -1878,7 +1921,7 @@        DataFamilyInst rep_tc ->         do { let -- eta-expand lhs types, because sometimes data/newtype-                 -- instances are eta-reduced; See Trac #9692+                 -- instances are eta-reduced; See #9692                  -- See Note [Eta reduction for data families] in FamInstEnv                  (ee_tvs, ee_lhs, _) = etaExpandCoAxBranch branch                  fam'     = reifyName fam@@ -1911,7 +1954,8 @@ reifyType ty                | tcIsLiftedTypeKind ty = return TH.StarT   -- Make sure to use tcIsLiftedTypeKind here, since we don't want to confuse it   -- with Constraint (#14869).-reifyType ty@(ForAllTy {})  = reify_for_all ty+reifyType ty@(ForAllTy (Bndr _ argf) _)+                            = reify_for_all argf ty reifyType (LitTy t)         = do { r <- reifyTyLit t; return (TH.LitT r) } reifyType (TyVarTy tv)      = return (TH.VarT (reifyName tv)) reifyType (TyConApp tc tys) = reify_tc_app tc tys   -- Do not expand type synonyms here@@ -1932,20 +1976,25 @@     filter_out_invisible_args ty_head ty_args =       filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args)                    ty_args-reifyType ty@(FunTy t1 t2)-  | isPredTy t1 = reify_for_all ty  -- Types like ((?x::Int) => Char -> Char)-  | otherwise   = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }+reifyType ty@(FunTy { ft_af = af, ft_arg = t1, ft_res = t2 })+  | InvisArg <- af = reify_for_all Inferred ty  -- Types like ((?x::Int) => Char -> Char)+  | otherwise      = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } reifyType (CastTy t _)      = reifyType t -- Casts are ignored in TH reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty) -reify_for_all :: TyCoRep.Type -> TcM TH.Type-reify_for_all ty-  = do { cxt' <- reifyCxt cxt;-       ; tau' <- reifyType tau-       ; tvs' <- reifyTyVars tvs-       ; return (TH.ForallT tvs' cxt' tau') }+reify_for_all :: TyCoRep.ArgFlag -> TyCoRep.Type -> TcM TH.Type+-- Arg of reify_for_all is always ForAllTy or a predicate FunTy+reify_for_all argf ty = do+  tvs' <- reifyTyVars tvs+  case argToForallVisFlag argf of+    ForallVis   -> do phi' <- reifyType phi+                      pure $ TH.ForallVisT tvs' phi'+    ForallInvis -> do let (cxt, tau) = tcSplitPhiTy phi+                      cxt' <- reifyCxt cxt+                      tau' <- reifyType tau+                      pure $ TH.ForallT tvs' cxt' tau'   where-    (tvs, cxt, tau) = tcSplitSigmaTy ty+    (tvs, phi) = tcSplitForAllTysSameVis argf ty  reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit reifyTyLit (NumTyLit n) = return (TH.NumTyLit n)@@ -1964,7 +2013,7 @@        ; req'        <- reifyCxt req        ; exTyVars'   <- reifyTyVars exTyVars        ; prov'       <- reifyCxt prov-       ; tau'        <- reifyType (mkFunTys argTys resTy)+       ; tau'        <- reifyType (mkVisFunTys argTys resTy)        ; return $ TH.ForallT univTyVars' req'                 $ TH.ForallT exTyVars' prov' tau' } @@ -2035,8 +2084,9 @@ ------------------------------ reifyName :: NamedThing n => n -> TH.Name reifyName thing-  | isExternalName name = mk_varg pkg_str mod_str occ_str-  | otherwise           = TH.mkNameU occ_str (getKey (getUnique name))+  | isExternalName name+              = mk_varg pkg_str mod_str occ_str+  | otherwise = TH.mkNameU occ_str (toInteger $ getKey (getUnique name))         -- Many of the things we reify have local bindings, and         -- NameL's aren't supposed to appear in binding positions, so         -- we use NameU.  When/if we start to reify nested things, that@@ -2101,6 +2151,23 @@ reifyDecidedStrictness HsLazy     = TH.DecidedLazy reifyDecidedStrictness HsStrict   = TH.DecidedStrict reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack++reifyTypeOfThing :: TH.Name -> TcM TH.Type+reifyTypeOfThing th_name = do+  thing <- getThing th_name+  case thing of+    AGlobal (AnId id) -> reifyType (idType id)+    AGlobal (ATyCon tc) -> reifyKind (tyConKind tc)+    AGlobal (AConLike (RealDataCon dc)) ->+      reifyType (idType (dataConWrapId dc))+    AGlobal (AConLike (PatSynCon ps)) ->+      reifyPatSynType (patSynSig ps)+    ATcId{tct_id = id} -> zonkTcType (idType id) >>= reifyType+    ATyVar _ tctv -> zonkTcTyVar tctv >>= reifyType+    -- Impossible cases, supposedly:+    AGlobal (ACoAxiom _) -> panic "reifyTypeOfThing: ACoAxiom"+    ATcTyCon _ -> panic "reifyTypeOfThing: ATcTyCon"+    APromotionErr _ -> panic "reifyTypeOfThing: APromotionErr"  ------------------------------ lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
compiler/typecheck/TcSplice.hs-boot view
@@ -5,13 +5,13 @@  import GhcPrelude import Name-import HsExpr   ( PendingRnSplice, DelayedSplice )+import GHC.Hs.Expr ( PendingRnSplice, DelayedSplice ) import TcRnTypes( TcM , SpliceType ) import TcType   ( ExpRhoType ) import Annotations ( Annotation, CoreAnnTarget )-import HsExtension ( GhcTcId, GhcRn, GhcPs, GhcTc )+import GHC.Hs.Extension ( GhcTcId, GhcRn, GhcPs, GhcTc ) -import HsSyn      ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat,+import GHC.Hs     ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat,                     LHsDecl, ThModFinalizers ) import qualified Language.Haskell.TH as TH
compiler/typecheck/TcTyClsDecls.hs view
@@ -15,3837 +15,4363 @@          -- Functions used by TcInstDcls to check         -- data/type family instance declarations-        kcConDecl, tcConDecls, dataDeclChecks, checkValidTyCon,-        tcFamTyPats, tcTyFamInstEqn,-        tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,-        unravelFamInstPats, addConsistencyConstraints,-        wrongKindOfFamily-    ) where--#include "GhclibHsVersions.h"--import GhcPrelude--import HsSyn-import HscTypes-import BuildTyCl-import TcRnMonad-import TcEnv-import TcValidity-import TcHsSyn-import TcTyDecls-import TcClassDcl-import {-# SOURCE #-} TcInstDcls( tcInstDecls1 )-import TcDeriv (DerivInfo)-import TcHsType-import ClsInst( AssocInstInfo(..) )-import Inst( tcInstTyBinders )-import TcMType-import TysWiredIn ( unitTy )-import TcType-import RnEnv( lookupConstructorFields )-import FamInst-import FamInstEnv-import Coercion-import Type-import TyCoRep   -- for checkValidRoles-import Class-import CoAxiom-import TyCon-import DataCon-import Id-import Var-import VarEnv-import VarSet-import Module-import Name-import NameSet-import NameEnv-import Outputable-import Maybes-import Unify-import Util-import SrcLoc-import ListSetOps-import DynFlags-import Unique-import ConLike( ConLike(..) )-import BasicTypes-import qualified GHC.LanguageExtensions as LangExt--import Control.Monad-import Data.List-import Data.List.NonEmpty ( NonEmpty(..) )-import qualified Data.Set as Set---{--************************************************************************-*                                                                      *-\subsection{Type checking for type and class declarations}-*                                                                      *-************************************************************************--Note [Grouping of type and class declarations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly-connected component of mutually dependent types and classes. We kind check and-type check each group separately to enhance kind polymorphism. Take the-following example:--  type Id a = a-  data X = X (Id Int)--If we were to kind check the two declarations together, we would give Id the-kind * -> *, since we apply it to an Int in the definition of X. But we can do-better than that, since Id really is kind polymorphic, and should get kind-forall (k::*). k -> k. Since it does not depend on anything else, it can be-kind-checked by itself, hence getting the most general kind. We then kind check-X, which works fine because we then know the polymorphic kind of Id, and simply-instantiate k to *.--Note [Check role annotations in a second pass]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Role inference potentially depends on the types of all of the datacons declared-in a mutually recursive group. The validity of a role annotation, in turn,-depends on the result of role inference. Because the types of datacons might-be ill-formed (see #7175 and Note [Checking GADT return types]) we must check-*all* the tycons in a group for validity before checking *any* of the roles.-Thus, we take two passes over the resulting tycons, first checking for general-validity and then checking for valid role annotations.--}--tcTyAndClassDecls :: [TyClGroup GhcRn]      -- Mutually-recursive groups in-                                            -- dependency order-                  -> TcM ( TcGblEnv         -- Input env extended by types and-                                            -- classes-                                            -- and their implicit Ids,DataCons-                         , [InstInfo GhcRn] -- Source-code instance decls info-                         , [DerivInfo]      -- data family deriving info-                         )--- Fails if there are any errors-tcTyAndClassDecls tyclds_s-  -- The code recovers internally, but if anything gave rise to-  -- an error we'd better stop now, to avoid a cascade-  -- Type check each group in dependency order folding the global env-  = checkNoErrs $ fold_env [] [] tyclds_s-  where-    fold_env :: [InstInfo GhcRn]-             -> [DerivInfo]-             -> [TyClGroup GhcRn]-             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])-    fold_env inst_info deriv_info []-      = do { gbl_env <- getGblEnv-           ; return (gbl_env, inst_info, deriv_info) }-    fold_env inst_info deriv_info (tyclds:tyclds_s)-      = do { (tcg_env, inst_info', deriv_info') <- tcTyClGroup tyclds-           ; setGblEnv tcg_env $-               -- remaining groups are typechecked in the extended global env.-             fold_env (inst_info' ++ inst_info)-                      (deriv_info' ++ deriv_info)-                      tyclds_s }--tcTyClGroup :: TyClGroup GhcRn-            -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])--- Typecheck one strongly-connected component of type, class, and instance decls--- See Note [TyClGroups and dependency analysis] in HsDecls-tcTyClGroup (TyClGroup { group_tyclds = tyclds-                       , group_roles  = roles-                       , group_instds = instds })-  = do { let role_annots = mkRoleAnnotEnv roles--           -- Step 1: Typecheck the type/class declarations-       ; traceTc "---- tcTyClGroup ---- {" empty-       ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds))-       ; tyclss <- tcTyClDecls tyclds role_annots--           -- Step 1.5: Make sure we don't have any type synonym cycles-       ; traceTc "Starting synonym cycle check" (ppr tyclss)-       ; this_uid <- fmap thisPackage getDynFlags-       ; checkSynCycles this_uid tyclss tyclds-       ; traceTc "Done synonym cycle check" (ppr tyclss)--           -- Step 2: Perform the validity check on those types/classes-           -- We can do this now because we are done with the recursive knot-           -- Do it before Step 3 (adding implicit things) because the latter-           -- expects well-formed TyCons-       ; traceTc "Starting validity check" (ppr tyclss)-       ; tyclss <- concatMapM checkValidTyCl tyclss-       ; traceTc "Done validity check" (ppr tyclss)-       ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss-           -- See Note [Check role annotations in a second pass]--       ; traceTc "---- end tcTyClGroup ---- }" empty--           -- Step 3: Add the implicit things;-           -- we want them in the environment because-           -- they may be mentioned in interface files-       ; gbl_env <- addTyConsToGblEnv tyclss--           -- Step 4: check instance declarations-       ; setGblEnv gbl_env $-         tcInstDecls1 instds }--tcTyClGroup (XTyClGroup _) = panic "tcTyClGroup"--tcTyClDecls :: [LTyClDecl GhcRn] -> RoleAnnotEnv -> TcM [TyCon]-tcTyClDecls tyclds role_annots-  = tcExtendKindEnv promotion_err_env $   --- See Note [Type environment evolution]-    do {    -- Step 1: kind-check this group and returns the final-            -- (possibly-polymorphic) kind of each TyCon and Class-            -- See Note [Kind checking for type and class decls]-         tc_tycons <- kcTyClGroup tyclds-       ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons))--            -- Step 2: type-check all groups together, returning-            -- the final TyCons and Classes-            ---            -- NB: We have to be careful here to NOT eagerly unfold-            -- type synonyms, as we have not tested for type synonym-            -- loops yet and could fall into a black hole.-       ; fixM $ \ ~rec_tyclss -> do-           { tcg_env <- getGblEnv-           ; let roles = inferRoles (tcg_src tcg_env) role_annots rec_tyclss--                 -- Populate environment with knot-tied ATyCon for TyCons-                 -- NB: if the decls mention any ill-staged data cons-                 -- (see Note [Recursion and promoting data constructors])-                 -- we will have failed already in kcTyClGroup, so no worries here-           ; tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $--                 -- Also extend the local type envt with bindings giving-                 -- a TcTyCon for each each knot-tied TyCon or Class-                 -- See Note [Type checking recursive type and class declarations]-                 -- and Note [Type environment evolution]-             tcExtendKindEnvWithTyCons tc_tycons $--                 -- Kind and type check declarations for this group-               mapM (tcTyClDecl roles) tyclds-           } }-  where-    promotion_err_env = mkPromotionErrorEnv tyclds-    ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma-                                  , ppr (tyConBinders tc) <> comma-                                  , ppr (tyConResKind tc)-                                  , ppr (isTcTyCon tc) ])--zipRecTyClss :: [TcTyCon]-             -> [TyCon]           -- Knot-tied-             -> [(Name,TyThing)]--- Build a name-TyThing mapping for the TyCons bound by decls--- being careful not to look at the knot-tied [TyThing]--- The TyThings in the result list must have a visible ATyCon,--- because typechecking types (in, say, tcTyClDecl) looks at--- this outer constructor-zipRecTyClss tc_tycons rec_tycons-  = [ (name, ATyCon (get name)) | tc_tycon <- tc_tycons, let name = getName tc_tycon ]-  where-    rec_tc_env :: NameEnv TyCon-    rec_tc_env = foldr add_tc emptyNameEnv rec_tycons--    add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon-    add_tc tc env = foldr add_one_tc env (tc : tyConATs tc)--    add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon-    add_one_tc tc env = extendNameEnv env (tyConName tc) tc--    get name = case lookupNameEnv rec_tc_env name of-                 Just tc -> tc-                 other   -> pprPanic "zipRecTyClss" (ppr name <+> ppr other)--{--************************************************************************-*                                                                      *-                Kind checking-*                                                                      *-************************************************************************--Note [Kind checking for type and class decls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Kind checking is done thus:--   1. Make up a kind variable for each parameter of the declarations,-      and extend the kind environment (which is in the TcLclEnv)--   2. Kind check the declarations--We need to kind check all types in the mutually recursive group-before we know the kind of the type variables.  For example:--  class C a where-     op :: D b => a -> b -> b--  class D c where-     bop :: (Monad c) => ...--Here, the kind of the locally-polymorphic type variable "b"-depends on *all the uses of class D*.  For example, the use of-Monad c in bop's type signature means that D must have kind Type->Type.--Note: we don't treat type synonyms specially (we used to, in the past);-in particular, even if we have a type synonym cycle, we still kind check-it normally, and test for cycles later (checkSynCycles).  The reason-we can get away with this is because we have more systematic TYPE r-inference, which means that we can do unification between kinds that-aren't lifted (this historically was not true.)--The downside of not directly reading off the kinds off the RHS of-type synonyms in topological order is that we don't transparently-support making synonyms of types with higher-rank kinds.  But-you can always specify a CUSK directly to make this work out.-See tc269 for an example.--Note [Skip decls with CUSKs in kcLTyClDecl]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider--    data T (a :: *) = MkT (S a)   -- Has CUSK-    data S a = MkS (T Int) (S a)  -- No CUSK--Via getInitialKinds we get-  T :: * -> *-  S :: kappa -> *--Then we call kcTyClDecl on each decl in the group, to constrain the-kind unification variables.  BUT we /skip/ the RHS of any decl with-a CUSK.  Here we skip the RHS of T, so we eventually get-  S :: forall k. k -> *--This gets us more polymorphism than we would otherwise get, similar-(but implemented strangely differently from) the treatment of type-signatures in value declarations.--Open type families-~~~~~~~~~~~~~~~~~~-This treatment of type synonyms only applies to Haskell 98-style synonyms.-General type functions can be recursive, and hence, appear in `alg_decls'.--The kind of an open type family is solely determinded by its kind signature;-hence, only kind signatures participate in the construction of the initial-kind environment (as constructed by `getInitialKind'). In fact, we ignore-instances of families altogether in the following. However, we need to include-the kinds of *associated* families into the construction of the initial kind-environment. (This is handled by `allDecls').--See also Note [Kind checking recursive type and class declarations]--Note [How TcTyCons work]-~~~~~~~~~~~~~~~~~~~~~~~~-TcTyCons are used for two distinct purposes--1.  When recovering from a type error in a type declaration,-    we want to put the erroneous TyCon in the environment in a-    way that won't lead to more errors.  We use a TcTyCon for this;-    see makeRecoveryTyCon.--2.  When checking a type/class declaration (in module TcTyClsDecls), we come-    upon knowledge of the eventual tycon in bits and pieces.--      S1) First, we use getInitialKinds to look over the user-provided-          kind signature of a tycon (including, for example, the number-          of parameters written to the tycon) to get an initial shape of-          the tycon's kind.  We record that shape in a TcTyCon.--          For CUSK tycons, the TcTyCon has the final, generalised kind.-          For non-CUSK tycons, the TcTyCon has as its tyConBinders only-          the explicit arguments given -- no kind variables, etc.--      S2) Then, using these initial kinds, we kind-check the body of the-          tycon (class methods, data constructors, etc.), filling in the-          metavariables in the tycon's initial kind.--      S3) We then generalize to get the (non-CUSK) tycon's final, fixed-          kind. Finally, once this has happened for all tycons in a-          mutually recursive group, we can desugar the lot.--    For convenience, we store partially-known tycons in TcTyCons, which-    might store meta-variables. These TcTyCons are stored in the local-    environment in TcTyClsDecls, until the real full TyCons can be created-    during desugaring. A desugared program should never have a TcTyCon.--3.  In a TcTyCon, everything is zonked after the kind-checking pass (S2).--4.  tyConScopedTyVars.  A challenging piece in all of this is that we-    end up taking three separate passes over every declaration:-      - one in getInitialKind (this pass look only at the head, not the body)-      - one in kcTyClDecls (to kind-check the body)-      - a final one in tcTyClDecls (to desugar)--    In the latter two passes, we need to connect the user-written type-    variables in an LHsQTyVars with the variables in the tycon's-    inferred kind. Because the tycon might not have a CUSK, this-    matching up is, in general, quite hard to do.  (Look through the-    git history between Dec 2015 and Apr 2016 for-    TcHsType.splitTelescopeTvs!)--    Instead of trying, we just store the list of type variables to-    bring into scope, in the tyConScopedTyVars field of the TcTyCon.-    These tyvars are brought into scope in TcHsType.bindTyClTyVars.--    In a TcTyCon, why is tyConScopedTyVars :: [(Name,TcTyVar)] rather-    than just [TcTyVar]?  Consider these mutually-recursive decls-       data T (a :: k1) b = MkT (S a b)-       data S (c :: k2) d = MkS (T c d)-    We start with k1 bound to kappa1, and k2 to kappa2; so initially-    in the (Name,TcTyVar) pairs the Name is that of the TcTyVar. But-    then kappa1 and kappa2 get unified; so after the zonking in-    'generalise' in 'kcTyClGroup' the Name and TcTyVar may differ.--See also Note [Type checking recursive type and class declarations].--Note [Type environment evolution]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As we typecheck a group of declarations the type environment evolves.-Consider for example:-  data B (a :: Type) = MkB (Proxy 'MkB)--We do the following steps:--  1. Start of tcTyClDecls: use mkPromotionErrorEnv to initialise the-     type env with promotion errors-            B   :-> TyConPE-            MkB :-> DataConPE--  2. kcTyCLGruup-      - Do getInitialKinds, which will signal a promotion-        error if B is used in any of the kinds needed to initialse-        B's kind (e.g. (a :: Type)) here--      - Extend the type env with these initial kinds (monomorphic for-        decls that lack a CUSK)-            B :-> TcTyCon <initial kind>-        (thereby overriding the B :-> TyConPE binding)-        and do kcLTyClDecl on each decl to get equality constraints on-        all those inital kinds--      - Generalise the inital kind, making a poly-kinded TcTyCon--  3. Back in tcTyDecls, extend the envt with bindings of the poly-kinded-     TcTyCons, again overriding the promotion-error bindings.--     But note that the data constructor promotion errors are still in place-     so that (in our example) a use of MkB will sitll be signalled as-     an error.--  4. Typecheck the decls.--  5. In tcTyClGroup, extend the envt with bindings for TyCon and DataCons---Note [Missed opportunity to retain higher-rank kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In 'kcTyClGroup', there is a missed opportunity to make kind-inference work in a few more cases.  The idea is analogous-to Note [Single function non-recursive binding special-case]:--     * If we have an SCC with a single decl, which is non-recursive,-       instead of creating a unification variable representing the-       kind of the decl and unifying it with the rhs, we can just-       read the type directly of the rhs.--     * Furthermore, we can update our SCC analysis to ignore-       dependencies on declarations which have CUSKs: we don't-       have to kind-check these all at once, since we can use-       the CUSK to initialize the kind environment.--Unfortunately this requires reworking a bit of the code in-'kcLTyClDecl' so I've decided to punt unless someone shouts about it.--Note [Don't process associated types in kcLHsQTyVars]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Previously, we processed associated types in the thing_inside in kcLHsQTyVars,-but this was wrong -- we want to do ATs sepearately.-The consequence for not doing it this way is #15142:--  class ListTuple (tuple :: Type) (as :: [(k, Type)]) where-    type ListToTuple as :: Type--We assign k a kind kappa[1]. When checking the tuple (k, Type), we try to unify-kappa ~ Type, but this gets deferred because we bumped the TcLevel as we bring-`tuple` into scope. Thus, when we check ListToTuple, kappa[1] still hasn't-unified with Type. And then, when we generalize the kind of ListToTuple (which-indeed has a CUSK, according to the rules), we skolemize the free metavariable-kappa. Note that we wouldn't skolemize kappa when generalizing the kind of ListTuple,-because the solveEqualities in kcLHsQTyVars is at TcLevel 1 and so kappa[1]-will unify with Type.--Bottom line: as associated types should have no effect on a CUSK enclosing class,-we move processing them to a separate action, run after the outer kind has-been generalized.---}--kcTyClGroup :: [LTyClDecl GhcRn] -> TcM [TcTyCon]---- Kind check this group, kind generalize, and return the resulting local env--- This binds the TyCons and Classes of the group, but not the DataCons--- See Note [Kind checking for type and class decls]--- and Note [Inferring kinds for type declarations]-kcTyClGroup decls-  = do  { mod <- getModule-        ; traceTc "---- kcTyClGroup ---- {"-                  (text "module" <+> ppr mod $$ vcat (map ppr decls))--          -- Kind checking;-          --    1. Bind kind variables for decls-          --    2. Kind-check decls-          --    3. Generalise the inferred kinds-          -- See Note [Kind checking for type and class decls]--        ; let (cusk_decls, no_cusk_decls)-                 = partition (hsDeclHasCusk . unLoc) decls--        ; poly_cusk_tcs <- getInitialKinds True cusk_decls--        ; mono_tcs-            <- tcExtendKindEnvWithTyCons poly_cusk_tcs $-               pushTcLevelM_   $  -- We are going to kind-generalise, so-                                  -- unification variables in here must-                                  -- be one level in-               solveEqualities $-               do {  -- Step 1: Bind kind variables for all decls-                    mono_tcs <- getInitialKinds False no_cusk_decls--                  ; traceTc "kcTyClGroup: initial kinds" $-                    ppr_tc_kinds mono_tcs--                    -- Step 2: Set extended envt, kind-check the decls-                    -- NB: the environment extension overrides the tycon-                    --     promotion-errors bindings-                    --     See Note [Type environment evolution]-                  ; tcExtendKindEnvWithTyCons mono_tcs $-                    mapM_ kcLTyClDecl no_cusk_decls--                  ; return mono_tcs }--        -- Step 3: generalisation-        -- Finally, go through each tycon and give it its final kind,-        -- with all the required, specified, and inferred variables-        -- in order.-        ; poly_no_cusk_tcs <- mapAndReportM generaliseTcTyCon mono_tcs--        ; let poly_tcs = poly_cusk_tcs ++ poly_no_cusk_tcs-        ; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs)-        ; return poly_tcs }--  where-    ppr_tc_kinds tcs = vcat (map pp_tc tcs)-    pp_tc tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc)--generaliseTcTyCon :: TcTyCon -> TcM TcTyCon-generaliseTcTyCon tc-  -- See Note [Required, Specified, and Inferred for types]-  = setSrcSpan (getSrcSpan tc) $-    addTyConCtxt tc $-    do { let tc_name     = tyConName tc-             tc_flav     = tyConFlavour tc-             tc_res_kind = tyConResKind tc-             tc_tvs      = tyConTyVars  tc-             user_tyvars = tcTyConUserTyVars tc  -- ToDo: nuke--             (scoped_tv_names, scoped_tvs) = unzip (tcTyConScopedTyVars tc)-             -- NB: scoped_tvs includes both specified and required (tc_tvs)-             -- ToDo: Is this a good idea?--       -- Step 1: find all the variables we want to quantify over,-       --         including Inferred, Specfied, and Required-       ; dvs <- candidateQTyVarsOfKinds $-                (tc_res_kind : map tyVarKind scoped_tvs)-       ; tc_tvs      <- mapM zonkTcTyVarToTyVar tc_tvs-       ; let full_dvs = dvs { dv_tvs = mkDVarSet tc_tvs }--       -- Step 2: quantify, mainly meaning skolemise the free variables-       ; qtkvs <- quantifyTyVars emptyVarSet full_dvs-                  -- Returned 'qtkvs' are scope-sorted and skolemised--       -- Step 3: find the final identity of the Specified and Required tc_tvs-       -- (remember they all started as TyVarTvs).-       -- They have been skolemised by quantifyTyVars.-       ; scoped_tvs  <- mapM zonkTcTyVarToTyVar scoped_tvs-       ; tc_tvs      <- mapM zonkTcTyVarToTyVar tc_tvs-       ; tc_res_kind <- zonkTcType tc_res_kind--       ; traceTc "Generalise kind pre" $-         vcat [ text "tycon =" <+> ppr tc-              , text "tc_tvs =" <+> pprTyVars tc_tvs-              , text "scoped_tvs =" <+> pprTyVars scoped_tvs ]--       -- Step 4: Find the Specified and Inferred variables-       -- First, delete the Required tc_tvs from qtkvs; then-       -- partition by whether they are scoped (if so, Specified)-       ; let qtkv_set      = mkVarSet qtkvs-             tc_tv_set     = mkVarSet tc_tvs-             specified     = scopedSort $-                             [ tv | tv <- scoped_tvs-                                  , not (tv `elemVarSet` tc_tv_set)-                                  , tv `elemVarSet` qtkv_set ]-                             -- NB: maintain the L-R order of scoped_tvs-             spec_req_set  = mkVarSet specified `unionVarSet` tc_tv_set-             inferred      = filterOut (`elemVarSet` spec_req_set) qtkvs--       -- Step 5: Make the TyConBinders.-             dep_fv_set     = candidateKindVars dvs-             inferred_tcbs  = mkNamedTyConBinders Inferred inferred-             specified_tcbs = mkNamedTyConBinders Specified specified-             required_tcbs  = map (mkRequiredTyConBinder dep_fv_set) tc_tvs--       -- Step 6: Assemble the final list.-             final_tcbs = concat [ inferred_tcbs-                                 , specified_tcbs-                                 , required_tcbs ]--             scoped_tv_pairs = scoped_tv_names `zip` scoped_tvs--       -- Step 7: Make the result TcTyCon-             tycon = mkTcTyCon tc_name user_tyvars final_tcbs tc_res_kind-                            scoped_tv_pairs-                            True {- it's generalised now -}-                            (tyConFlavour tc)--       ; traceTc "Generalise kind" $-         vcat [ text "tycon =" <+> ppr tc-              , text "tc_tvs =" <+> pprTyVars tc_tvs-              , text "tc_res_kind =" <+> ppr tc_res_kind-              , text "scoped_tvs =" <+> pprTyVars scoped_tvs-              , text "inferred =" <+> pprTyVars inferred-              , text "specified =" <+> pprTyVars specified-              , text "required_tcbs =" <+> ppr required_tcbs-              , text "final_tcbs =" <+> ppr final_tcbs ]--       -- Step 8: check for floating kind vars-       -- See Note [Free-floating kind vars]-       -- They are easily identified by the fact that they-       -- have not been skolemised by quantifyTyVars-       ; let floating_specified = filter isTyVarTyVar scoped_tvs-       ; reportFloatingKvs tc_name tc_flav-                           scoped_tvs floating_specified--       -- Step 9: Check for duplicates-       -- E.g. data SameKind (a::k) (b::k)-       --      data T (a::k1) (b::k2) = MkT (SameKind a b)-       -- Here k1 and k2 start as TyVarTvs, and get unified with each other-       ; mapM_ report_sig_tv_err (findDupTyVarTvs scoped_tv_pairs)--       -- Step 10: Check for validity.-       -- We do this here because we're about to put the tycon into-       -- the environment, and we don't want anything malformed in the-       -- environment.-       ; checkValidTelescope tycon--       ; return tycon }-  where-    report_sig_tv_err (n1, n2)-      = setSrcSpan (getSrcSpan n2) $-        addErrTc (text "Couldn't match" <+> quotes (ppr n1)-                        <+> text "with" <+> quotes (ppr n2))--{- Note [Required, Specified, and Inferred for types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Each forall'd type variable in a type or kind is one of--  * Required: an argument must be provided at every call site--  * Specified: the argument can be inferred at call sites, but-    may be instantiated with visible type/kind application--  * Inferred: the must be inferred at call sites; it-    is unavailable for use with visible type/kind application.--Why have Inferred at all? Because we just can't make user-facing-promises about the ordering of some variables. These might swizzle-around even between minor released. By forbidding visible type-application, we ensure users aren't caught unawares.--Go read Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.--The question for this Note is this:-   given a TyClDecl, how are its quantified type variables classified?-Much of the debate is memorialized in #15743.--Here is our design choice. When inferring the ordering of variables-for a TyCl declaration (that is, for those variables that he user-has not specified the order with an explicit `forall`), we use the-following order:-- 1. Inferred variables- 2. Specified variables; in the left-to-right order in which-    the user wrote them, modified by scopedSort (see below)-    to put them in depdendency order.- 3. Required variables before a top-level ::- 4. All variables after a top-level ::--If this ordering does not make a valid telescope, we reject the definition.--Example:-  data SameKind :: k -> k -> *-  data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d)--For X:-  - a, c, d, x are Required; they are explicitly listed by the user-    as the positional arguments of Bad-  - b is Specified; it appears explicitly in a kind signature-  - k, the kind of a, is Inferred; it is not mentioned explicitly at all--Putting variables in the order Inferred, Specified, Required-gives us this telescope:-  Inferred:  k-  Specified: b : Proxy a-  Required : (a : k) (c : Proxy b) (d : Proxy a) (x : SameKind b d)--But this order is ill-scoped, because b's kind mentions a, which occurs-after b in the telescope. So we reject Bad.--Associated types-~~~~~~~~~~~~~~~~-For associated types everything above is determined by the-associated-type declaration alone, ignoring the class header.-Here is an example (Trac #15592)-  class C (a :: k) b where-    type F (x :: b a)--In the kind of C, 'k' is Specified.  But what about F?-In the kind of F,-- * Should k be Inferred or Specified?  It's Specified for C,-   but not mentioned in F's declaration.-- * In which order should the Specified variables a and b occur?-   It's clearly 'a' then 'b' in C's declaration, but the L-R ordering-   in F's declaration is 'b' then 'a'.--In both cases we make the choice by looking at F's declaration alone,-so it gets the kind-   F :: forall {k}. forall b a. b a -> Type--How it works-~~~~~~~~~~~~-These design choices are implemented by two completely different code-paths for--  * Declarations with a compulete user-specified kind signature (CUSK)-    Handed by the CUSK case of kcLHsQTyVars.--  * Declarations without a CUSK are handled by kcTyClDecl; see-    Note [Inferring kinds for type declarations].--Note that neither code path worries about point (4) above, as this-is nicely handled by not mangling the res_kind. (Mangling res_kinds is done-*after* all this stuff, in tcDataDefn's call to etaExpandAlgTyCon.)--We can tell Inferred apart from Specified by looking at the scoped-tyvars; Specified are always included there.--Design alternatives-~~~~~~~~~~~~~~~~~~~--* For associated types we considered putting the class variables-  before the local variables, in a nod to the treatment for class-  methods. But it got too compilicated; see Trac #15592, comment:21ff.--* We rigidly require the ordering above, even though we could be much more-  permissive. Relevant musings are at-  https://ghc.haskell.org/trac/ghc/ticket/15743#comment:7-  The bottom line conclusion is that, if the user wants a different ordering,-  then can specify it themselves, and it is better to be predictable and dumb-  than clever and capricious.--  I (Richard) conjecture we could be fully permissive, allowing all classes-  of variables to intermix. We would have to augment ScopedSort to refuse to-  reorder Required variables (or check that it wouldn't have). But this would-  allow more programs. See #15743 for examples. Interestingly, Idris seems-  to allow this intermixing. The intermixing would be fully specified, in that-  we can be sure that inference wouldn't change between versions. However,-  would users be able to predict it? That I cannot answer.--Test cases (and tickets) relevant to these design decisions-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-  T15591*-  T15592*-  T15743*--Note [Inferring kinds for type declarations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This note deals with /inference/ for type declarations-that do not have a CUSK.  Consider-  data T (a :: k1) k2 (x :: k2) = MkT (S a k2 x)-  data S (b :: k3) k4 (y :: k4) = MkS (T b k4 y)--We do kind inference as follows:--* Step 1: Assign initial monomorophic kinds to S, T-          S :: kk1 -> * -> kk2 -> *-          T :: kk3 -> * -> kk4 -> *-  Here kk1 etc are TyVarTvs: that is, unification variables that-  are allowed to unify only with other type variables. See-  Note [Signature skolems] in TcType--* Step 2: Extend the environment with a TcTyCon for S and T, with-  these monomophic kinds.  Now kind-check the declarations, and solve-  the resulting equalities.  The goal here is to discover constraints-  on all these unification variables.--  Here we find that kk1 := kk3, and kk2 := kk4.--  This is why we can't use skolems for kk1 etc; they have to-  unify with each other.--* Step 3. Generalise each TyCon in turn (generaliseTcTyCon).-  We find the free variables of the kind, skolemise them,-  sort them out into Inferred/Required/Specified (see the above-  Note [Required, Specified, and Inferred for types]),-  and perform some validity checks.--  This makes the utterly-final TyConBinders for the TyCon--  All this is very similar at the level of terms: see TcBinds-  Note [Quantified variables in partial type signatures]--* Step 4.  Extend the type environment with a TcTyCon for S and T, now-  with their utterly-final polymorphic kinds (needed for recursive-  occurrences of S, T).  Now typecheck the declarations, and build the-  final AlgTyCOn for S and T resp.--The first three steps are in kcTyClGroup;-the fourth is in tcTyClDecls.--There are some wrinkles--* Do not default TyVarTvs.  We always want to kind-generalise over-  TyVarTvs, and /not/ default them to Type. By definition a TyVarTv is-  not allowed to unify with a type; it must stand for a type-  variable. Hence the check in TcSimplify.defaultTyVarTcS, and-  TcMType.defaultTyVar.  Here's another example (Trac #14555):-     data Exp :: [TYPE rep] -> TYPE rep -> Type where-        Lam :: Exp (a:xs) b -> Exp xs (a -> b)-  We want to kind-generalise over the 'rep' variable.-  Trac #14563 is another example.--* Duplicate type variables. Consider Trac #11203-    data SameKind :: k -> k -> *-    data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b)-  Here we will unify k1 with k2, but this time doing so is an error,-  because k1 and k2 are bound in the same declaration.--  We spot this during validity checking (findDupTyVarTvs),-  in generaliseTcTyCon.--* Required arguments.  Even the Required arguments should be made-  into TyVarTvs, not skolems.  Consider-    data T k (a :: k)-  Here, k is a Required, dependent variable. For uniformity, it is helpful-  to have k be a TyVarTv, in parallel with other dependent variables.--* Duplicate skolemisation is expected.  When generalising in Step 3,-  we may find that one of the variables we want to quantify has-  already been skolemised.  For example, suppose we have already-  generalise S. When we come to T we'll find that kk1 (now the same as-  kk3) has already been skolemised.--  That's fine -- but it means that-    a) when collecting quantification candidates, in-       candidateQTyVarsOfKind, we must collect skolems-    b) quantifyTyVars should be a no-op on such a skolem--}-----------------tcExtendKindEnvWithTyCons :: [TcTyCon] -> TcM a -> TcM a-tcExtendKindEnvWithTyCons tcs-  = tcExtendKindEnvList [ (tyConName tc, ATcTyCon tc) | tc <- tcs ]-----------------mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv--- Maps each tycon/datacon to a suitable promotion error---    tc :-> APromotionErr TyConPE---    dc :-> APromotionErr RecDataConPE---    See Note [Recursion and promoting data constructors]--mkPromotionErrorEnv decls-  = foldr (plusNameEnv . mk_prom_err_env . unLoc)-          emptyNameEnv decls--mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv-mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats })-  = unitNameEnv nm (APromotionErr ClassPE)-    `plusNameEnv`-    mkNameEnv [ (name, APromotionErr TyConPE)-              | (dL->L _ (FamilyDecl { fdLName = (dL->L _ name) })) <- ats ]--mk_prom_err_env (DataDecl { tcdLName = (dL->L _ name)-                          , tcdDataDefn = HsDataDefn { dd_cons = cons } })-  = unitNameEnv name (APromotionErr TyConPE)-    `plusNameEnv`-    mkNameEnv [ (con, APromotionErr RecDataConPE)-              | (dL->L _ con') <- cons-              , (dL->L _ con)  <- getConNames con' ]--mk_prom_err_env decl-  = unitNameEnv (tcdName decl) (APromotionErr TyConPE)-    -- Works for family declarations too-----------------getInitialKinds :: Bool -> [LTyClDecl GhcRn] -> TcM [TcTyCon]--- Returns a TcTyCon for each TyCon bound by the decls,--- each with its initial kind--getInitialKinds cusk decls-  = do { traceTc "getInitialKinds {" empty-       ; tcs <- concatMapM (addLocM (getInitialKind cusk)) decls-       ; traceTc "getInitialKinds done }" empty-       ; return tcs }--getInitialKind :: Bool -> TyClDecl GhcRn -> TcM [TcTyCon]--- Allocate a fresh kind variable for each TyCon and Class--- For each tycon, return a TcTyCon with kind k--- where k is the kind of tc, derived from the LHS---         of the definition (and probably including---         kind unification variables)---      Example: data T a b = ...---      return (T, kv1 -> kv2 -> kv3)------ This pass deals with (ie incorporates into the kind it produces)---   * The kind signatures on type-variable binders---   * The result kinds signature on a TyClDecl------ No family instances are passed to getInitialKinds--getInitialKind cusk-    (ClassDecl { tcdLName = dL->L _ name-               , tcdTyVars = ktvs-               , tcdATs = ats })-  = do { tycon <- kcLHsQTyVars name ClassFlavour cusk ktvs $-                  return constraintKind-       ; let parent_tv_prs = tcTyConScopedTyVars tycon-            -- See Note [Don't process associated types in kcLHsQTyVars]-       ; inner_tcs <- tcExtendNameTyVarEnv parent_tv_prs $-                      getFamDeclInitialKinds (Just tycon) ats-       ; return (tycon : inner_tcs) }--getInitialKind cusk-    (DataDecl { tcdLName = dL->L _ name-              , tcdTyVars = ktvs-              , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig-                                         , dd_ND = new_or_data } })-  = do  { let flav = newOrDataToFlavour new_or_data-        ; tc <- kcLHsQTyVars name flav cusk ktvs $-                case m_sig of-                   Just ksig -> tcLHsKindSig (DataKindCtxt name) ksig-                   Nothing   -> return liftedTypeKind-        ; return [tc] }--getInitialKind _ (FamDecl { tcdFam = decl })-  = do { tc <- getFamDeclInitialKind Nothing decl-       ; return [tc] }--getInitialKind cusk (SynDecl { tcdLName = dL->L _ name-                             , tcdTyVars = ktvs-                             , tcdRhs = rhs })-  = do  { tycon <- kcLHsQTyVars name TypeSynonymFlavour cusk ktvs $-                   case kind_annotation rhs of-                     Just ksig -> tcLHsKindSig (TySynKindCtxt name) ksig-                     Nothing   -> newMetaKindVar-        ; return [tycon] }-  where-    -- Keep this synchronized with 'hsDeclHasCusk'.-    kind_annotation (dL->L _ ty) = case ty of-        HsParTy _ lty     -> kind_annotation lty-        HsKindSig _ _ k   -> Just k-        _                 -> Nothing--getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn _)) = panic "getInitialKind"-getInitialKind _ (XTyClDecl _) = panic "getInitialKind"------------------------------------getFamDeclInitialKinds-  :: Maybe TcTyCon -- ^ Enclosing class TcTyCon, if any-  -> [LFamilyDecl GhcRn]-  -> TcM [TcTyCon]-getFamDeclInitialKinds mb_parent_tycon decls-  = mapM (addLocM (getFamDeclInitialKind mb_parent_tycon)) decls--getFamDeclInitialKind-  :: Maybe TcTyCon -- ^ Enclosing class TcTyCon, if any-  -> FamilyDecl GhcRn-  -> TcM TcTyCon-getFamDeclInitialKind mb_parent_tycon-    decl@(FamilyDecl { fdLName     = (dL->L _ name)-                     , fdTyVars    = ktvs-                     , fdResultSig = (dL->L _ resultSig)-                     , fdInfo      = info })-  = kcLHsQTyVars name flav cusk ktvs $-    case resultSig of-      KindSig _ ki                              -> tcLHsKindSig ctxt ki-      TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki-      _ -- open type families have * return kind by default-        | tcFlavourIsOpen flav              -> return liftedTypeKind-               -- closed type families have their return kind inferred-               -- by default-        | otherwise                         -> newMetaKindVar-  where-    mb_cusk = tcTyConIsPoly <$> mb_parent_tycon-    cusk    = famDeclHasCusk mb_cusk decl-    flav  = case info of-      DataFamily         -> DataFamilyFlavour mb_parent_tycon-      OpenTypeFamily     -> OpenTypeFamilyFlavour mb_parent_tycon-      ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon )-                            ClosedTypeFamilyFlavour-    ctxt  = TyFamResKindCtxt name-getFamDeclInitialKind _ (XFamilyDecl _) = panic "getFamDeclInitialKind"---------------------------------------------------------------------------kcLTyClDecl :: LTyClDecl GhcRn -> TcM ()-  -- See Note [Kind checking for type and class decls]-kcLTyClDecl (dL->L loc decl)-  = setSrcSpan loc $-    tcAddDeclCtxt decl $-    do { traceTc "kcTyClDecl {" (ppr tc_name)-       ; kcTyClDecl decl-       ; traceTc "kcTyClDecl done }" (ppr tc_name) }-  where-    tc_name = tyClDeclLName decl--kcTyClDecl :: TyClDecl GhcRn -> TcM ()--- This function is used solely for its side effect on kind variables--- NB kind signatures on the type variables and---    result kind signature have already been dealt with---    by getInitialKind, so we can ignore them here.--kcTyClDecl (DataDecl { tcdLName    = (dL->L _ name)-                     , tcdDataDefn = defn })-  | HsDataDefn { dd_cons = cons@((dL->L _ (ConDeclGADT {})) : _)-               , dd_ctxt = (dL->L _ []) } <- defn-  = mapM_ (wrapLocM_ kcConDecl) cons-    -- hs_tvs and dd_kindSig already dealt with in getInitialKind-    -- This must be a GADT-style decl,-    --        (see invariants of DataDefn declaration)-    -- so (a) we don't need to bring the hs_tvs into scope, because the-    --        ConDecls bind all their own variables-    --    (b) dd_ctxt is not allowed for GADT-style decls, so we can ignore it--  | HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } <- defn-  = bindTyClTyVars name $ \ _ _ ->-    do  { _ <- tcHsContext ctxt-        ; mapM_ (wrapLocM_ kcConDecl) cons }--kcTyClDecl (SynDecl { tcdLName = dL->L _ name, tcdRhs = rhs })-  = bindTyClTyVars name $ \ _ res_kind ->-    discardResult $ tcCheckLHsType rhs res_kind-        -- NB: check against the result kind that we allocated-        -- in getInitialKinds.--kcTyClDecl (ClassDecl { tcdLName = (dL->L _ name)-                      , tcdCtxt = ctxt, tcdSigs = sigs })-  = bindTyClTyVars name $ \ _ _ ->-    do  { _ <- tcHsContext ctxt-        ; mapM_ (wrapLocM_ kc_sig) sigs }-  where-    kc_sig (ClassOpSig _ _ nms op_ty) = kcClassSigType skol_info nms op_ty-    kc_sig _                          = return ()--    skol_info = TyConSkol ClassFlavour name--kcTyClDecl (FamDecl _ (FamilyDecl { fdLName  = (dL->L _ fam_tc_name)-                                  , fdInfo   = fd_info }))--- closed type families look at their equations, but other families don't--- do anything here-  = case fd_info of-      ClosedTypeFamily (Just eqns) ->-        do { fam_tc <- kcLookupTcTyCon fam_tc_name-           ; mapM_ (kcTyFamInstEqn fam_tc) eqns }-      _ -> return ()-kcTyClDecl (FamDecl _ (XFamilyDecl _))              = panic "kcTyClDecl"-kcTyClDecl (DataDecl _ _ _ _ (XHsDataDefn _)) = panic "kcTyClDecl"-kcTyClDecl (XTyClDecl _)                            = panic "kcTyClDecl"----------------------kcConDecl :: ConDecl GhcRn -> TcM ()-kcConDecl (ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs-                      , con_mb_cxt = ex_ctxt, con_args = args })-  = addErrCtxt (dataConCtxtName [name]) $-    discardResult                   $-    bindExplicitTKBndrs_Skol ex_tvs $-    do { _ <- tcHsMbContext ex_ctxt-       ; traceTc "kcConDecl {" (ppr name $$ ppr args)-       ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args)-       ; traceTc "kcConDecl }" (ppr name)-       }-              -- We don't need to check the telescope here, because that's-              -- done in tcConDecl--kcConDecl (ConDeclGADT { con_names = names-                       , con_qvars = qtvs, con_mb_cxt = cxt-                       , con_args = args, con_res_ty = res_ty })-  | HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = implicit_tkv_nms }-           , hsq_explicit = explicit_tkv_nms } <- qtvs-  = -- Even though the data constructor's type is closed, we-    -- must still kind-check the type, because that may influence-    -- the inferred kind of the /type/ constructor.  Example:-    --    data T f a where-    --      MkT :: f a -> T f a-    -- If we don't look at MkT we won't get the correct kind-    -- for the type constructor T-    addErrCtxt (dataConCtxtName names) $-    discardResult $-    bindImplicitTKBndrs_Tv implicit_tkv_nms $-    bindExplicitTKBndrs_Tv explicit_tkv_nms $-        -- Why "_Tv"?  See Note [Kind-checking for GADTs]-    do { _ <- tcHsMbContext cxt-       ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args)-       ; _ <- tcHsOpenType res_ty-       ; return () }-kcConDecl (XConDecl _) = panic "kcConDecl"-kcConDecl (ConDeclGADT _ _ _ (XLHsQTyVars _) _ _ _ _) = panic "kcConDecl"--{--Note [Recursion and promoting data constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We don't want to allow promotion in a strongly connected component-when kind checking.--Consider:-  data T f = K (f (K Any))--When kind checking the `data T' declaration the local env contains the-mappings:-  T -> ATcTyCon <some initial kind>-  K -> APromotionErr--APromotionErr is only used for DataCons, and only used during type checking-in tcTyClGroup.--Note [Kind-checking for GADTs]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider--  data Proxy a where-    MkProxy1 :: forall k (b :: k). Proxy b-    MkProxy2 :: forall j (c :: j). Proxy c--It seems reasonable that this should be accepted. But something very strange-is going on here: when we're kind-checking this declaration, we need to unify-the kind of `a` with k and j -- even though k and j's scopes are local to the type of-MkProxy{1,2}. The best approach we've come up with is to use TyVarTvs during-the kind-checking pass. First off, note that it's OK if the kind-checking pass-is too permissive: we'll snag the problems in the type-checking pass later.-(This extra permissiveness might happen with something like--  data SameKind :: k -> k -> Type-  data Bad a where-    MkBad :: forall k1 k2 (a :: k1) (b :: k2). Bad (SameKind a b)--which would be accepted if k1 and k2 were TyVarTvs. This is correctly rejected-in the second pass, though. Test case: polykinds/TyVarTvKinds3)-Recall that the kind-checking pass exists solely to collect constraints-on the kinds and to power unification.--To achieve the use of TyVarTvs, we must be careful to use specialized functions-that produce TyVarTvs, not ordinary skolems. This is why we need-kcExplicitTKBndrs and kcImplicitTKBndrs in TcHsType, separate from their-tc... variants.--The drawback of this approach is sometimes it will accept a definition that-a (hypothetical) declarative specification would likely reject. As a general-rule, we don't want to allow polymorphic recursion without a CUSK. Indeed,-the whole point of CUSKs is to allow polymorphic recursion. Yet, the TyVarTvs-approach allows a limited form of polymorphic recursion *without* a CUSK.--To wit:-  data T a = forall k (b :: k). MkT (T b) Int-  (test case: dependent/should_compile/T14066a)--Note that this is polymorphically recursive, with the recursive occurrence-of T used at a kind other than a's kind. The approach outlined here accepts-this definition, because this kind is still a kind variable (and so the-TyVarTvs unify). Stepping back, I (Richard) have a hard time envisioning a-way to describe exactly what declarations will be accepted and which will-be rejected (without a CUSK). However, the accepted definitions are indeed-well-kinded and any rejected definitions would be accepted with a CUSK,-and so this wrinkle need not cause anyone to lose sleep.--************************************************************************-*                                                                      *-\subsection{Type checking}-*                                                                      *-************************************************************************--Note [Type checking recursive type and class declarations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-At this point we have completed *kind-checking* of a mutually-recursive group of type/class decls (done in kcTyClGroup). However,-we discarded the kind-checked types (eg RHSs of data type decls);-note that kcTyClDecl returns ().  There are two reasons:--  * It's convenient, because we don't have to rebuild a-    kinded HsDecl (a fairly elaborate type)--  * It's necessary, because after kind-generalisation, the-    TyCons/Classes may now be kind-polymorphic, and hence need-    to be given kind arguments.--Example:-       data T f a = MkT (f a) (T f a)-During kind-checking, we give T the kind T :: k1 -> k2 -> *-and figure out constraints on k1, k2 etc. Then we generalise-to get   T :: forall k. (k->*) -> k -> *-So now the (T f a) in the RHS must be elaborated to (T k f a).--However, during tcTyClDecl of T (above) we will be in a recursive-"knot". So we aren't allowed to look at the TyCon T itself; we are only-allowed to put it (lazily) in the returned structures.  But when-kind-checking the RHS of T's decl, we *do* need to know T's kind (so-that we can correctly elaboarate (T k f a).  How can we get T's kind-without looking at T?  Delicate answer: during tcTyClDecl, we extend--  *Global* env with T -> ATyCon (the (not yet built) final TyCon for T)-  *Local*  env with T -> ATcTyCon (TcTyCon with the polymorphic kind of T)--Then:--  * During TcHsType.tcTyVar we look in the *local* env, to get the-    fully-known, not knot-tied TcTyCon for T.--  * Then, in TcHsSyn.zonkTcTypeToType (and zonkTcTyCon in particular)-    we look in the *global* env to get the TyCon.--This fancy footwork (with two bindings for T) is only necessary for the-TyCons or Classes of this recursive group.  Earlier, finished groups,-live in the global env only.--See also Note [Kind checking recursive type and class declarations]--Note [Kind checking recursive type and class declarations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Before we can type-check the decls, we must kind check them. This-is done by establishing an "initial kind", which is a rather uninformed-guess at a tycon's kind (by counting arguments, mainly) and then-using this initial kind for recursive occurrences.--The initial kind is stored in exactly the same way during-kind-checking as it is during type-checking (Note [Type checking-recursive type and class declarations]): in the *local* environment,-with ATcTyCon. But we still must store *something* in the *global*-environment. Even though we discard the result of kind-checking, we-sometimes need to produce error messages. These error messages will-want to refer to the tycons being checked, except that they don't-exist yet, and it would be Terribly Annoying to get the error messages-to refer back to HsSyn. So we create a TcTyCon and put it in the-global env. This tycon can print out its name and knows its kind, but-any other action taken on it will panic. Note that TcTyCons are *not*-knot-tied, unlike the rather valid but knot-tied ones that occur-during type-checking.--Note [Declarations for wired-in things]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For wired-in things we simply ignore the declaration-and take the wired-in information.  That avoids complications.-e.g. the need to make the data constructor worker name for-     a constraint tuple match the wired-in one--}--tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM TyCon-tcTyClDecl roles_info (dL->L loc decl)-  | Just thing <- wiredInNameTyThing_maybe (tcdName decl)-  = case thing of -- See Note [Declarations for wired-in things]-      ATyCon tc -> return tc-      _ -> pprPanic "tcTyClDecl" (ppr thing)--  | otherwise-  = setSrcSpan loc $ tcAddDeclCtxt decl $-    do { traceTc "---- tcTyClDecl ---- {" (ppr decl)-       ; tc <- tcTyClDecl1 Nothing roles_info decl-       ; traceTc "---- tcTyClDecl end ---- }" (ppr tc)-       ; return tc }--  -- "type family" declarations-tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM TyCon-tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd })-  = tcFamDecl1 parent fd--  -- "type" synonym declaration-tcTyClDecl1 _parent roles_info-            (SynDecl { tcdLName = (dL->L _ tc_name)-                     , tcdRhs   = rhs })-  = ASSERT( isNothing _parent )-    bindTyClTyVars tc_name $ \ binders res_kind ->-    tcTySynRhs roles_info tc_name binders res_kind rhs--  -- "data/newtype" declaration-tcTyClDecl1 _parent roles_info-            (DataDecl { tcdLName = (dL->L _ tc_name)-                      , tcdDataDefn = defn })-  = ASSERT( isNothing _parent )-    bindTyClTyVars tc_name $ \ tycon_binders res_kind ->-    tcDataDefn roles_info tc_name tycon_binders res_kind defn--tcTyClDecl1 _parent roles_info-            (ClassDecl { tcdLName = (dL->L _ class_name)-                       , tcdCtxt = hs_ctxt-                       , tcdMeths = meths-                       , tcdFDs = fundeps-                       , tcdSigs = sigs-                       , tcdATs = ats-                       , tcdATDefs = at_defs })-  = ASSERT( isNothing _parent )-    do { clas <- tcClassDecl1 roles_info class_name hs_ctxt-                              meths fundeps sigs ats at_defs-       ; return (classTyCon clas) }--tcTyClDecl1 _ _ (XTyClDecl _) = panic "tcTyClDecl1"---{- *********************************************************************-*                                                                      *-          Class declarations-*                                                                      *-********************************************************************* -}--tcClassDecl1 :: RolesInfo -> Name -> LHsContext GhcRn-             -> LHsBinds GhcRn -> [LHsFunDep GhcRn] -> [LSig GhcRn]-             -> [LFamilyDecl GhcRn] -> [LTyFamDefltEqn GhcRn]-             -> TcM Class-tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs-  = fixM $ \ clas ->-    -- We need the knot because 'clas' is passed into tcClassATs-    bindTyClTyVars class_name $ \ binders res_kind ->-    do { MASSERT2( tcIsConstraintKind res_kind-                 , ppr class_name $$ ppr res_kind )-       ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders)-       ; let tycon_name = class_name        -- We use the same name-             roles = roles_info tycon_name  -- for TyCon and Class--       ; (ctxt, fds, sig_stuff, at_stuff)-            <- pushTcLevelM_   $-               solveEqualities $-               do { ctxt <- tcHsContext hs_ctxt-                  ; fds  <- mapM (addLocM tc_fundep) fundeps-                  ; sig_stuff <- tcClassSigs class_name sigs meths-                  ; at_stuff  <- tcClassATs class_name clas ats at_defs-                  ; return (ctxt, fds, sig_stuff, at_stuff) }--       -- The solveEqualities will report errors for any-       -- unsolved equalities, so these zonks should not encounter-       -- any unfilled coercion variables unless there is such an error-       -- The zonk also squeeze out the TcTyCons, and converts-       -- Skolems to tyvars.-       ; ze        <- emptyZonkEnv-       ; ctxt      <- zonkTcTypesToTypesX ze ctxt-       ; sig_stuff <- mapM (zonkTcMethInfoToMethInfoX ze) sig_stuff-         -- ToDo: do we need to zonk at_stuff?--       -- TODO: Allow us to distinguish between abstract class,-       -- and concrete class with no methods (maybe by-       -- specifying a trailing where or not--       ; mindef <- tcClassMinimalDef class_name sigs sig_stuff-       ; is_boot <- tcIsHsBootOrSig-       ; let body | is_boot, null ctxt, null at_stuff, null sig_stuff-                  = Nothing-                  | otherwise-                  = Just (ctxt, at_stuff, sig_stuff, mindef)--       ; clas <- buildClass class_name binders roles fds body-       ; traceTc "tcClassDecl" (ppr fundeps $$ ppr binders $$-                                ppr fds)-       ; return clas }-  where-    tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ;-                                ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ;-                                ; return (tvs1', tvs2') }---{- Note [Associated type defaults]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The following is an example of associated type defaults:-             class C a where-               data D a--               type F a b :: *-               type F a b = [a]        -- Default--Note that we can get default definitions only for type families, not data-families.--}--tcClassATs :: Name                   -- The class name (not knot-tied)-           -> Class                  -- The class parent of this associated type-           -> [LFamilyDecl GhcRn]    -- Associated types.-           -> [LTyFamDefltEqn GhcRn] -- Associated type defaults.-           -> TcM [ClassATItem]-tcClassATs class_name cls ats at_defs-  = do {  -- Complain about associated type defaults for non associated-types-         sequence_ [ failWithTc (badATErr class_name n)-                   | n <- map at_def_tycon at_defs-                   , not (n `elemNameSet` at_names) ]-       ; mapM tc_at ats }-  where-    at_def_tycon :: LTyFamDefltEqn GhcRn -> Name-    at_def_tycon (dL->L _ eqn) = unLoc (feqn_tycon eqn)--    at_fam_name :: LFamilyDecl GhcRn -> Name-    at_fam_name (dL->L _ decl) = unLoc (fdLName decl)--    at_names = mkNameSet (map at_fam_name ats)--    at_defs_map :: NameEnv [LTyFamDefltEqn GhcRn]-    -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs'-    at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv-                                          (at_def_tycon at_def) [at_def])-                        emptyNameEnv at_defs--    tc_at at = do { fam_tc <- addLocM (tcFamDecl1 (Just cls)) at-                  ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at)-                                  `orElse` []-                  ; atd <- tcDefaultAssocDecl fam_tc at_defs-                  ; return (ATI fam_tc atd) }----------------------------tcDefaultAssocDecl :: TyCon                    -- ^ Family TyCon (not knot-tied)-                   -> [LTyFamDefltEqn GhcRn]        -- ^ Defaults-                   -> TcM (Maybe (KnotTied Type, SrcSpan))   -- ^ Type checked RHS-tcDefaultAssocDecl _ []-  = return Nothing  -- No default declaration--tcDefaultAssocDecl _ (d1:_:_)-  = failWithTc (text "More than one default declaration for"-                <+> ppr (feqn_tycon (unLoc d1)))--tcDefaultAssocDecl fam_tc [dL->L loc (FamEqn { feqn_tycon = L _ tc_name-                                             , feqn_pats = hs_tvs-                                             , feqn_rhs = hs_rhs_ty })]-  | HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = imp_vars}-           , hsq_explicit = exp_vars } <- hs_tvs-  = -- See Note [Type-checking default assoc decls]-    setSrcSpan loc $-    tcAddFamInstCtxt (text "default type instance") tc_name $-    do { traceTc "tcDefaultAssocDecl" (ppr tc_name)-       ; let fam_tc_name = tyConName fam_tc-             fam_arity = length (tyConVisibleTyVars fam_tc)--       -- Kind of family check-       ; ASSERT( fam_tc_name == tc_name )-         checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)--       -- Arity check-       ; checkTc (exp_vars `lengthIs` fam_arity)-                 (wrongNumberOfParmsErr fam_arity)--       -- Typecheck RHS-       ; let hs_pats = map (HsValArg . hsLTyVarBndrToType) exp_vars--          -- NB: Use tcFamTyPats, not bindTyClTyVars. The latter expects to get-          -- the LHsQTyVars used for declaring a tycon, but the names here-          -- are different.--          -- You might think we should pass in some AssocInstInfo, as we're looking-          -- at an associated type. But this would be wrong, because an associated-          -- type default LHS can mention *different* type variables than the-          -- enclosing class. So it's treated more as a freestanding beast.-       ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc NotAssociated-                                                    imp_vars exp_vars-                                                    hs_pats hs_rhs_ty--         -- See Note [Type-checking default assoc decls]-       ; traceTc "tcDefault" (vcat [ppr (tyConTyVars fam_tc), ppr qtvs, ppr pats])-       ; case tcMatchTys pats (mkTyVarTys (tyConTyVars fam_tc)) of-           Just subst -> return (Just (substTyUnchecked subst rhs_ty, loc) )-           Nothing    -> failWithTc (defaultAssocKindErr fam_tc)-           -- We check for well-formedness and validity later,-           -- in checkValidClass-     }-tcDefaultAssocDecl _ [dL->L _ (XFamEqn _)] = panic "tcDefaultAssocDecl"-tcDefaultAssocDecl _ [dL->L _ (FamEqn _ _ _ (XLHsQTyVars _) _ _)]-  = panic "tcDefaultAssocDecl"-tcDefaultAssocDecl _ [_]-  = panic "tcDefaultAssocDecl: Impossible Match" -- due to #15884---{- Note [Type-checking default assoc decls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this default declaration for an associated type--   class C a where-      type F (a :: k) b :: *-      type F x y = Proxy x -> y--Note that the class variable 'a' doesn't scope over the default assoc-decl (rather oddly I think), and (less oddly) neither does the second-argument 'b' of the associated type 'F', or the kind variable 'k'.-Instead, the default decl is treated more like a top-level type-instance.--However we store the default rhs (Proxy x -> y) in F's TyCon, using-F's own type variables, so we need to convert it to (Proxy a -> b).-We do this by calling tcMatchTys to match them up.  This also ensures-that x's kind matches a's and similarly for y and b.  The error-message isn't great, mind you.  (Trac #11361 was caused by not doing a-proper tcMatchTys here.)--Recall also that the left-hand side of an associated type family-default is always just variables -- no tycons here. Accordingly,-the patterns used in the tcMatchTys won't actually be knot-tied,-even though we're in the knot. This is too delicate for my taste,-but it works.---}--{- *********************************************************************-*                                                                      *-          Type family declarations-*                                                                      *-********************************************************************* -}--tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon-tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info-                              , fdLName = tc_lname@(dL->L _ tc_name)-                              , fdResultSig = (dL->L _ sig)-                              , fdTyVars = user_tyvars-                              , fdInjectivityAnn = inj })-  | DataFamily <- fam_info-  = bindTyClTyVars tc_name $ \ binders res_kind -> do-  { traceTc "data family:" (ppr tc_name)-  ; checkFamFlag tc_name--  -- Check that the result kind is OK-  -- We allow things like-  --   data family T (a :: Type) :: forall k. k -> Type-  -- We treat T as having arity 1, but result kind forall k. k -> Type-  -- But we want to check that the result kind finishes in-  --   Type or a kind-variable-  -- For the latter, consider-  --   data family D a :: forall k. Type -> k-  ; let (_, final_res_kind) = splitPiTys res_kind-  ; checkTc (tcIsLiftedTypeKind final_res_kind-             || isJust (tcGetCastedTyVar_maybe final_res_kind))-            (badKindSig False res_kind)--  ; tc_rep_name <- newTyConRepName tc_name-  ; let tycon = mkFamilyTyCon tc_name binders-                              res_kind-                              (resultVariableName sig)-                              (DataFamilyTyCon tc_rep_name)-                              parent NotInjective-  ; return tycon }--  | OpenTypeFamily <- fam_info-  = bindTyClTyVars tc_name $ \ binders res_kind -> do-  { traceTc "open type family:" (ppr tc_name)-  ; checkFamFlag tc_name-  ; inj' <- tcInjectivity binders inj-  ; let tycon = mkFamilyTyCon tc_name binders res_kind-                               (resultVariableName sig) OpenSynFamilyTyCon-                               parent inj'-  ; return tycon }--  | ClosedTypeFamily mb_eqns <- fam_info-  = -- Closed type families are a little tricky, because they contain the definition-    -- of both the type family and the equations for a CoAxiom.-    do { traceTc "Closed type family:" (ppr tc_name)-         -- the variables in the header scope only over the injectivity-         -- declaration but this is not involved here-       ; (inj', binders, res_kind)-            <- bindTyClTyVars tc_name $ \ binders res_kind ->-               do { inj' <- tcInjectivity binders inj-                  ; return (inj', binders, res_kind) }--       ; checkFamFlag tc_name -- make sure we have -XTypeFamilies--         -- If Nothing, this is an abstract family in a hs-boot file;-         -- but eqns might be empty in the Just case as well-       ; case mb_eqns of-           Nothing   ->-               return $ mkFamilyTyCon tc_name binders res_kind-                                      (resultVariableName sig)-                                      AbstractClosedSynFamilyTyCon parent-                                      inj'-           Just eqns -> do {--         -- Process the equations, creating CoAxBranches-       ; let tc_fam_tc = mkTcTyCon tc_name (ppr user_tyvars) binders res_kind-                                   [] False {- this doesn't matter here -}-                                   ClosedTypeFamilyFlavour--       ; branches <- mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns-         -- Do not attempt to drop equations dominated by earlier-         -- ones here; in the case of mutual recursion with a data-         -- type, we get a knot-tying failure.  Instead we check-         -- for this afterwards, in TcValidity.checkValidCoAxiom-         -- Example: tc265--         -- Create a CoAxiom, with the correct src location.-       ; co_ax_name <- newFamInstAxiomName tc_lname []--       ; let mb_co_ax-              | null eqns = Nothing   -- mkBranchedCoAxiom fails on empty list-              | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches)--             fam_tc = mkFamilyTyCon tc_name binders res_kind (resultVariableName sig)-                      (ClosedSynFamilyTyCon mb_co_ax) parent inj'--         -- We check for instance validity later, when doing validity-         -- checking for the tycon. Exception: checking equations-         -- overlap done by dropDominatedAxioms-       ; return fam_tc } }--  | otherwise = panic "tcFamInst1"  -- Silence pattern-exhaustiveness checker-tcFamDecl1 _ (XFamilyDecl _) = panic "tcFamDecl1"---- | Maybe return a list of Bools that say whether a type family was declared--- injective in the corresponding type arguments. Length of the list is equal to--- the number of arguments (including implicit kind/coercion arguments).--- True on position--- N means that a function is injective in its Nth argument. False means it is--- not.-tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn)-              -> TcM Injectivity-tcInjectivity _ Nothing-  = return NotInjective--  -- User provided an injectivity annotation, so for each tyvar argument we-  -- check whether a type family was declared injective in that argument. We-  -- return a list of Bools, where True means that corresponding type variable-  -- was mentioned in lInjNames (type family is injective in that argument) and-  -- False means that it was not mentioned in lInjNames (type family is not-  -- injective in that type variable). We also extend injectivity information to-  -- kind variables, so if a user declares:-  ---  --   type family F (a :: k1) (b :: k2) = (r :: k3) | r -> a-  ---  -- then we mark both `a` and `k1` as injective.-  -- NB: the return kind is considered to be *input* argument to a type family.-  -- Since injectivity allows to infer input arguments from the result in theory-  -- we should always mark the result kind variable (`k3` in this example) as-  -- injective.  The reason is that result type has always an assigned kind and-  -- therefore we can always infer the result kind if we know the result type.-  -- But this does not seem to be useful in any way so we don't do it.  (Another-  -- reason is that the implementation would not be straightforward.)-tcInjectivity tcbs (Just (dL->L loc (InjectivityAnn _ lInjNames)))-  = setSrcSpan loc $-    do { let tvs = binderVars tcbs-       ; dflags <- getDynFlags-       ; checkTc (xopt LangExt.TypeFamilyDependencies dflags)-                 (text "Illegal injectivity annotation" $$-                  text "Use TypeFamilyDependencies to allow this")-       ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames-       ; inj_tvs <- mapM zonkTcTyVarToTyVar inj_tvs -- zonk the kinds-       ; let inj_ktvs = filterVarSet isTyVar $  -- no injective coercion vars-                        closeOverKinds (mkVarSet inj_tvs)-       ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs-       ; traceTc "tcInjectivity" (vcat [ ppr tvs, ppr lInjNames, ppr inj_tvs-                                       , ppr inj_ktvs, ppr inj_bools ])-       ; return $ Injective inj_bools }--tcTySynRhs :: RolesInfo-           -> Name-           -> [TyConBinder] -> Kind-           -> LHsType GhcRn -> TcM TyCon-tcTySynRhs roles_info tc_name binders res_kind hs_ty-  = do { env <- getLclEnv-       ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))-       ; rhs_ty <- pushTcLevelM_   $-                   solveEqualities $-                   tcCheckLHsType hs_ty res_kind-       ; rhs_ty <- zonkTcTypeToType rhs_ty-       ; let roles = roles_info tc_name-             tycon = buildSynTyCon tc_name binders res_kind roles rhs_ty-       ; return tycon }--tcDataDefn :: RolesInfo -> Name-           -> [TyConBinder] -> Kind-           -> HsDataDefn GhcRn -> TcM TyCon-  -- NB: not used for newtype/data instances (whether associated or not)-tcDataDefn roles_info-           tc_name tycon_binders res_kind-           (HsDataDefn { dd_ND = new_or_data, dd_cType = cType-                       , dd_ctxt = ctxt-                       , dd_kindSig = mb_ksig  -- Already in tc's kind-                                               -- via getInitialKinds-                       , dd_cons = cons })- =  do { gadt_syntax <- dataDeclChecks tc_name new_or_data ctxt cons--       ; tcg_env <- getGblEnv-       ; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind--       ; let hsc_src = tcg_src tcg_env-       ; unless (mk_permissive_kind hsc_src cons) $-         checkTc (tcIsLiftedTypeKind final_res_kind) (badKindSig True res_kind)--       ; stupid_tc_theta <- pushTcLevelM_ $ solveEqualities $ tcHsContext ctxt-       ; stupid_theta    <- zonkTcTypesToTypes stupid_tc_theta-       ; kind_signatures <- xoptM LangExt.KindSignatures--             -- Check that we don't use kind signatures without Glasgow extensions-       ; when (isJust mb_ksig) $-         checkTc (kind_signatures) (badSigTyDecl tc_name)--       ; tycon <- fixM $ \ tycon -> do-             { let final_bndrs = tycon_binders `chkAppend` extra_bndrs-                   res_ty      = mkTyConApp tycon (mkTyVarTys (binderVars final_bndrs))-                   roles       = roles_info tc_name--             ; data_cons <- tcConDecls tycon final_bndrs res_ty cons-             ; tc_rhs    <- mk_tc_rhs hsc_src tycon data_cons-             ; tc_rep_nm <- newTyConRepName tc_name-             ; return (mkAlgTyCon tc_name-                                  final_bndrs-                                  final_res_kind-                                  roles-                                  (fmap unLoc cType)-                                  stupid_theta tc_rhs-                                  (VanillaAlgTyCon tc_rep_nm)-                                  gadt_syntax) }-       ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs)-       ; return tycon }-  where-    -- Abstract data types in hsig files can have arbitrary kinds,-    -- because they may be implemented by type synonyms-    -- (which themselves can have arbitrary kinds, not just *)-    mk_permissive_kind HsigFile [] = True-    mk_permissive_kind _ _ = False--    -- In hs-boot, a 'data' declaration with no constructors-    -- indicates a nominally distinct abstract data type.-    mk_tc_rhs HsBootFile _ []-      = return AbstractTyCon--    mk_tc_rhs HsigFile _ [] -- ditto-      = return AbstractTyCon--    mk_tc_rhs _ tycon data_cons-      = case new_or_data of-          DataType -> return (mkDataTyConRhs data_cons)-          NewType  -> ASSERT( not (null data_cons) )-                      mkNewTyConRhs tc_name tycon (head data_cons)-tcDataDefn _ _ _ _ (XHsDataDefn _) = panic "tcDataDefn"-----------------------------kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM ()--- Used for the equations of a closed type family only--- Not used for data/type instances-kcTyFamInstEqn tc_fam_tc-    (dL->L loc (HsIB { hsib_ext = imp_vars-                     , hsib_body = FamEqn { feqn_tycon = dL->L _ eqn_tc_name-                                          , feqn_bndrs = mb_expl_bndrs-                                          , feqn_pats  = hs_pats-                                          , feqn_rhs   = hs_rhs_ty }}))-  = setSrcSpan loc $-    do { traceTc "kcTyFamInstEqn" (vcat-           [ text "tc_name ="    <+> ppr eqn_tc_name-           , text "fam_tc ="     <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc)-           , text "hsib_vars ="  <+> ppr imp_vars-           , text "feqn_bndrs =" <+> ppr mb_expl_bndrs-           , text "feqn_pats ="  <+> ppr hs_pats ])-          -- this check reports an arity error instead of a kind error; easier for user-       ; let vis_pats = numVisibleArgs hs_pats-       ; checkTc (vis_pats == vis_arity) $-                  wrongNumberOfParmsErr vis_arity-       ; discardResult $-         bindImplicitTKBndrs_Q_Tv imp_vars $-         bindExplicitTKBndrs_Q_Tv AnyKind (mb_expl_bndrs `orElse` []) $-         do { (_, res_kind) <- tcFamTyPats tc_fam_tc hs_pats-            ; tcCheckLHsType hs_rhs_ty res_kind }-             -- Why "_Tv" here?  Consider (Trac #14066-             --  type family Bar x y where-             --      Bar (x :: a) (y :: b) = Int-             --      Bar (x :: c) (y :: d) = Bool-             -- During kind-checkig, a,b,c,d should be TyVarTvs and unify appropriately-    }-  where-    vis_arity = length (tyConVisibleTyVars tc_fam_tc)--kcTyFamInstEqn _ (dL->L _ (XHsImplicitBndrs _)) = panic "kcTyFamInstEqn"-kcTyFamInstEqn _ (dL->L _ (HsIB _ (XFamEqn _))) = panic "kcTyFamInstEqn"-kcTyFamInstEqn _ _ = panic "kcTyFamInstEqn: Impossible Match" -- due to #15884------------------------------tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn-               -> TcM (KnotTied CoAxBranch)--- Needs to be here, not in TcInstDcls, because closed families--- (typechecked here) have TyFamInstEqns--tcTyFamInstEqn fam_tc mb_clsinfo-    (dL->L loc (HsIB { hsib_ext = imp_vars-                 , hsib_body = FamEqn { feqn_tycon  = L _ eqn_tc_name-                                      , feqn_bndrs  = mb_expl_bndrs-                                      , feqn_pats   = hs_pats-                                      , feqn_rhs    = hs_rhs_ty }}))-  = ASSERT( getName fam_tc == eqn_tc_name )-    setSrcSpan loc $-    do {-       -- First, check the arity of visible arguments-       -- If we wait until validity checking, we'll get kind errors-       -- below when an arity error will be much easier to understand.-       ; let vis_arity = length (tyConVisibleTyVars fam_tc)-             vis_pats  = numVisibleArgs hs_pats-       ; checkTc (vis_pats == vis_arity) $-         wrongNumberOfParmsErr vis_arity--       ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo-                                      imp_vars (mb_expl_bndrs `orElse` [])-                                      hs_pats hs_rhs_ty--       -- Don't print results they may be knot-tied-       -- (tcFamInstEqnGuts zonks to Type)-       ; return (mkCoAxBranch qtvs [] [] pats rhs_ty-                              (map (const Nominal) qtvs)-                              loc) }--tcTyFamInstEqn _ _ _ = panic "tcTyFamInstEqn"--{--Kind check type patterns and kind annotate the embedded type variables.-     type instance F [a] = rhs-- * Here we check that a type instance matches its kind signature, but we do-   not check whether there is a pattern for each type index; the latter-   check is only required for type synonym instances.--Note [Instantiating a family tycon]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's possible that kind-checking the result of a family tycon applied to-its patterns will instantiate the tycon further. For example, we might-have--  type family F :: k where-    F = Int-    F = Maybe--After checking (F :: forall k. k) (with no visible patterns), we still need-to instantiate the k. With data family instances, this problem can be even-more intricate, due to Note [Arity of data families] in FamInstEnv. See-indexed-types/should_compile/T12369 for an example.--So, the kind-checker must return the new skolems and args (that is, Type-or (Type -> Type) for the equations above) and the instantiated kind.--Note [Generalising in tcFamTyPatsGuts]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have something like-  type instance forall (a::k) b. F t1 t2 = rhs--Then  imp_vars = [k], exp_bndrs = [a::k, b]--We want to quantify over-  * k, a, and b  (all user-specified)-  * and any inferred free kind vars from-      - the kinds of k, a, b-      - the types t1, t2--However, unlike a type signature like-  f :: forall (a::k). blah--we do /not/ care about the Inferred/Specified designation-or order for the final quantified tyvars.  Type-family-instances are not invoked directly in Haskell source code,-so visible type application etc plays no role.--So, the simple thing is-   - gather candiates from [k, a, b] and pats-   - quantify over them--Hence the sligtly mysterious call:-    candidateQTyVarsOfTypes (pats ++ mkTyVarTys scoped_tvs)--Simple, neat, but a little non-obvious!--}-----------------------------tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo-                   -> [Name] -> [LHsTyVarBndr GhcRn]  -- Implicit and explicicit binder-                   -> HsTyPats GhcRn                  -- Patterns-                   -> LHsType GhcRn                   -- RHS-                   -> TcM ([TyVar], [TcType], TcType)      -- (tyvars, pats, rhs)--- Used only for type families, not data families-tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty-  = do { traceTc "tcTyFamInstEqnGuts {" (vcat [ ppr fam_tc <+> ppr hs_pats ])--       -- By now, for type families (but not data families) we should-       -- have checked that the number of patterns matches tyConArity--       -- This code is closely related to the code-       -- in TcHsType.kcLHsQTyVars_Cusk-       ; (imp_tvs, (exp_tvs, (lhs_ty, rhs_ty)))-               <- pushTcLevelM_                                $-                  solveEqualities                              $-                  bindImplicitTKBndrs_Q_Skol imp_vars          $-                  bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $-                  do { (lhs_ty, rhs_kind) <- tc_lhs-                       -- Ensure that the instance is consistent with its-                       -- parent class (#16008)-                     ; addConsistencyConstraints mb_clsinfo lhs_ty-                     ; rhs_ty <- tcCheckLHsType hs_rhs_ty rhs_kind-                     ; return (lhs_ty, rhs_ty) }--       -- See Note [Generalising in tcFamTyPatsGuts]-       -- This code (and the stuff immediately above) is very similar-       -- to that in tcDataFamHeader.  Maybe we should abstract the-       -- common code; but for the moment I concluded that it's-       -- clearer to duplicate it.  Still, if you fix a bug here,-       -- check there too!-       ; let scoped_tvs = imp_tvs ++ exp_tvs-       ; dvs  <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs)-       ; qtvs <- quantifyTyVars emptyVarSet dvs--       ; (ze, qtvs) <- zonkTyBndrs qtvs-       ; lhs_ty     <- zonkTcTypeToTypeX ze lhs_ty-       ; rhs_ty     <- zonkTcTypeToTypeX ze rhs_ty--       ; let pats = unravelFamInstPats lhs_ty-             -- Note that we do this after solveEqualities-             -- so that any strange coercions inside lhs_ty-             -- have been solved before we attempt to unravel it-       ; traceTc "tcTyFamInstEqnGuts }" (ppr fam_tc <+> pprTyVars qtvs)-       ; return (qtvs, pats, rhs_ty) }-  where-    tc_lhs | null hs_pats  -- See Note [Apparently-nullary families]-           = do { (args, rhs_kind) <- tcInstTyBinders $-                                      splitPiTysInvisibleN (tyConArity fam_tc)-                                                           (tyConKind  fam_tc)-                ; return (mkTyConApp fam_tc args, rhs_kind) }-           | otherwise-           = tcFamTyPats fam_tc hs_pats--{- Note [Apparently-nullary families]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  type family F :: k -> *--This really means-  type family F @k :: k -> *--That is, the family has arity 1, and can match on the kind. So it's-not really a nullary family.   NB that-  type famly F2 :: forall k. k -> *-is quite different and really does have arity 0.--Returning to F we might have-  type instannce F = Maybe-which instantaite 'k' to '*' and really means-  type instannce F @* = Maybe--Conclusion: in this odd case where there are no LHS patterns, we-should instantiate any invisible foralls in F's kind, to saturate-its arity (but no more).  This is what happens in tc_lhs in-tcTyFamInstEqnGuts.--If there are any visible patterns, then the first will force-instantiation of any Inferred quantifiers for F -- remember,-Inferred quantifiers always come first.--}---------------------tcFamTyPats :: TyCon-            -> HsTyPats GhcRn                -- Patterns-            -> TcM (TcType, TcKind)          -- (lhs_type, lhs_kind)--- Used for both type and data families-tcFamTyPats fam_tc hs_pats-  = do { traceTc "tcFamTyPats {" $-         vcat [ ppr fam_tc <+> dcolon <+> ppr fam_kind-              , text "arity:" <+> ppr fam_arity-              , text "kind:" <+> ppr fam_kind ]--       ; let fun_ty = mkTyConApp fam_tc []--       ; (fam_app, res_kind) <- unsetWOptM Opt_WarnPartialTypeSignatures $-                                setXOptM LangExt.PartialTypeSignatures $-                                -- See Note [Wildcards in family instances] in-                                -- RnSource.hs-                                tcInferApps typeLevelMode lhs_fun fun_ty-                                            fam_kind hs_pats--       ; traceTc "End tcFamTyPats }" $-         vcat [ ppr fam_tc <+> dcolon <+> ppr fam_kind-              , text "res_kind:" <+> ppr res_kind ]--       ; return (fam_app, res_kind) }-  where-    fam_name  = tyConName fam_tc-    fam_arity = tyConArity fam_tc-    fam_kind  = tyConKind fam_tc-    lhs_fun   = noLoc (HsTyVar noExt NotPromoted (noLoc fam_name))--unravelFamInstPats :: TcType -> [TcType]--- Decompose fam_app to get the argument patterns------ We expect fam_app to look like (F t1 .. tn)--- tcInferApps is capable of returning ((F ty1 |> co) ty2),--- but that can't happen here because we already checked the--- arity of F matches the number of pattern-unravelFamInstPats fam_app-  = case splitTyConApp_maybe fam_app of-      Just (_, pats) -> pats-      Nothing        -> WARN( True, bad_lhs fam_app ) []-        -- The Nothing case cannot happen for type families, because-        -- we don't call unravelFamInstPats until we've solved the-        -- equalities.  For data families I wasn't quite as convinced-        -- so I've let it as a warning rather than a panic.-  where-    bad_lhs fam_app-      = hang (text "Ill-typed LHS of family instance")-           2 (debugPprType fam_app)--addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM ()--- In the corresponding positions of the class and type-family,--- ensure the the family argument is the same as the class argument---   E.g    class C a b c d where---             F c x y a :: Type--- Here the first  arg of F should be the same as the third of C---  and the fourth arg of F should be the same as the first of C------ We emit /Derived/ constraints (a bit like fundeps) to encourage--- unification to happen, but without actually reporting errors.--- If, despite the efforts, corresponding positions do not match,--- checkConsistentFamInst will complain-addConsistencyConstraints mb_clsinfo fam_app-  | InClsInst { ai_inst_env = inst_env } <- mb_clsinfo-  , Just (fam_tc, pats) <- tcSplitTyConApp_maybe fam_app-  = do { let eqs = [ (cls_ty, pat)-                   | (fam_tc_tv, pat) <- tyConTyVars fam_tc `zip` pats-                   , Just cls_ty <- [lookupVarEnv inst_env fam_tc_tv] ]-       ; traceTc "addConsistencyConstraints" (ppr eqs)-       ; emitDerivedEqs AssocFamPatOrigin eqs }-    -- Improve inference-    -- Any mis-match is reports by checkConsistentFamInst-  | otherwise-  = return ()--{- Note [Constraints in patterns]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-NB: This isn't the whole story. See comment in tcFamTyPats.--At first glance, it seems there is a complicated story to tell in tcFamTyPats-around constraint solving. After all, type family patterns can now do-GADT pattern-matching, which is jolly complicated. But, there's a key fact-which makes this all simple: everything is at top level! There cannot-be untouchable type variables. There can't be weird interaction between-case branches. There can't be global skolems.--This means that the semantics of type-level GADT matching is a little-different than term level. If we have--  data G a where-    MkGBool :: G Bool--And then--  type family F (a :: G k) :: k-  type instance F MkGBool = True--we get--  axF : F Bool (MkGBool <Bool>) ~ True--Simple! No casting on the RHS, because we can affect the kind parameter-to F.--If we ever introduce local type families, this all gets a lot more-complicated, and will end up looking awfully like term-level GADT-pattern-matching.---** The new story **--Here is really what we want:--The matcher really can't deal with covars in arbitrary spots in coercions.-But it can deal with covars that are arguments to GADT data constructors.-So we somehow want to allow covars only in precisely those spots, then use-them as givens when checking the RHS. TODO (RAE): Implement plan.---Note [Quantifying over family patterns]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We need to quantify over two different lots of kind variables:--First, the ones that come from the kinds of the tyvar args of-tcTyVarBndrsKindGen, as usual-  data family Dist a--  -- Proxy :: forall k. k -> *-  data instance Dist (Proxy a) = DP-  -- Generates  data DistProxy = DP-  --            ax8 k (a::k) :: Dist * (Proxy k a) ~ DistProxy k a-  -- The 'k' comes from the tcTyVarBndrsKindGen (a::k)--Second, the ones that come from the kind argument of the type family-which we pick up using the (tyCoVarsOfTypes typats) in the result of-the thing_inside of tcHsTyvarBndrsGen.-  -- Any :: forall k. k-  data instance Dist Any = DA-  -- Generates  data DistAny k = DA-  --            ax7 k :: Dist k (Any k) ~ DistAny k-  -- The 'k' comes from kindGeneralizeKinds (Any k)--Note [Quantified kind variables of a family pattern]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider   type family KindFam (p :: k1) (q :: k1)-           data T :: Maybe k1 -> k2 -> *-           type instance KindFam (a :: Maybe k) b = T a b -> Int-The HsBSig for the family patterns will be ([k], [a])--Then in the family instance we want to-  * Bring into scope [ "k" -> k:*, "a" -> a:k ]-  * Kind-check the RHS-  * Quantify the type instance over k and k', as well as a,b, thus-       type instance [k, k', a:Maybe k, b:k']-                     KindFam (Maybe k) k' a b = T k k' a b -> Int--Notice that in the third step we quantify over all the visibly-mentioned-type variables (a,b), but also over the implicitly mentioned kind variables-(k, k').  In this case one is bound explicitly but often there will be-none. The role of the kind signature (a :: Maybe k) is to add a constraint-that 'a' must have that kind, and to bring 'k' into scope.----************************************************************************-*                                                                      *-               Data types-*                                                                      *-************************************************************************--}--dataDeclChecks :: Name -> NewOrData-               -> LHsContext GhcRn -> [LConDecl GhcRn]-               -> TcM Bool-dataDeclChecks tc_name new_or_data (L _ stupid_theta) cons-  = do {   -- Check that we don't use GADT syntax in H98 world-         gadtSyntax_ok <- xoptM LangExt.GADTSyntax-       ; let gadt_syntax = consUseGadtSyntax cons-       ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name)--           -- Check that the stupid theta is empty for a GADT-style declaration-       ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name)--         -- Check that a newtype has exactly one constructor-         -- Do this before checking for empty data decls, so that-         -- we don't suggest -XEmptyDataDecls for newtypes-       ; checkTc (new_or_data == DataType || isSingleton cons)-                (newtypeConError tc_name (length cons))--         -- Check that there's at least one condecl,-         -- or else we're reading an hs-boot file, or -XEmptyDataDecls-       ; empty_data_decls <- xoptM LangExt.EmptyDataDecls-       ; is_boot <- tcIsHsBootOrSig  -- Are we compiling an hs-boot file?-       ; checkTc (not (null cons) || empty_data_decls || is_boot)-                 (emptyConDeclsErr tc_name)-       ; return gadt_syntax }---------------------------------------consUseGadtSyntax :: [LConDecl a] -> Bool-consUseGadtSyntax ((dL->L _ (ConDeclGADT {})) : _) = True-consUseGadtSyntax _                                = False-                 -- All constructors have same shape--------------------------------------tcConDecls :: KnotTied TyCon -> [KnotTied TyConBinder] -> KnotTied Type-           -> [LConDecl GhcRn] -> TcM [DataCon]-  -- Why both the tycon tyvars and binders? Because the tyvars-  -- have all the names and the binders have the visibilities.-tcConDecls rep_tycon tmpl_bndrs res_tmpl-  = concatMapM $ addLocM $-    tcConDecl rep_tycon (mkTyConTagMap rep_tycon) tmpl_bndrs res_tmpl-    -- It's important that we pay for tag allocation here, once per TyCon,-    -- See Note [Constructor tag allocation], fixes #14657--tcConDecl :: KnotTied TyCon          -- Representation tycon. Knot-tied!-          -> NameEnv ConTag-          -> [KnotTied TyConBinder] -> KnotTied Type-                 -- Return type template (with its template tyvars)-                 --    (tvs, T tys), where T is the family TyCon-          -> ConDecl GhcRn-          -> TcM [DataCon]--tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl-          (ConDeclH98 { con_name = name-                      , con_ex_tvs = explicit_tkv_nms-                      , con_mb_cxt = hs_ctxt-                      , con_args = hs_args })-  = addErrCtxt (dataConCtxtName [name]) $-    do { -- NB: the tyvars from the declaration header are in scope--         -- Get hold of the existential type variables-         -- e.g. data T a = forall k (b::k) f. MkT a (f b)-         -- Here tmpl_bndrs = {a}-         --      hs_qvars = HsQTvs { hsq_implicit = {k}-         --                        , hsq_explicit = {f,b} }--       ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ])--       ; (exp_tvs, (ctxt, arg_tys, field_lbls, stricts))-           <- pushTcLevelM_                             $-              solveEqualities                           $-              bindExplicitTKBndrs_Skol explicit_tkv_nms $-              do { ctxt <- tcHsMbContext hs_ctxt-                 ; btys <- tcConArgs hs_args-                 ; field_lbls <- lookupConstructorFields (unLoc name)-                 ; let (arg_tys, stricts) = unzip btys-                 ; return (ctxt, arg_tys, field_lbls, stricts)-                 }--         -- exp_tvs have explicit, user-written binding sites-         -- the kvs below are those kind variables entirely unmentioned by the user-         --   and discovered only by generalization--       ; kvs <- kindGeneralize (mkSpecForAllTys (binderVars tmpl_bndrs) $-                                mkSpecForAllTys exp_tvs $-                                mkFunTys ctxt $-                                mkFunTys arg_tys $-                                unitTy)-                 -- That type is a lie, of course. (It shouldn't end in ()!)-                 -- And we could construct a proper result type from the info-                 -- at hand. But the result would mention only the tmpl_tvs,-                 -- and so it just creates more work to do it right. Really,-                 -- we're only doing this to find the right kind variables to-                 -- quantify over, and this type is fine for that purpose.--             -- Zonk to Types-       ; (ze, qkvs)      <- zonkTyBndrs kvs-       ; (ze, user_qtvs) <- zonkTyBndrsX ze exp_tvs-       ; arg_tys         <- zonkTcTypesToTypesX ze arg_tys-       ; ctxt            <- zonkTcTypesToTypesX ze ctxt--       ; fam_envs <- tcGetFamInstEnvs--       -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here-       ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls)-       ; let-           univ_tvbs = tyConTyVarBinders tmpl_bndrs-           univ_tvs  = binderVars univ_tvbs-           ex_tvbs   = mkTyVarBinders Inferred qkvs ++-                       mkTyVarBinders Specified user_qtvs-           ex_tvs    = qkvs ++ user_qtvs-           -- For H98 datatypes, the user-written tyvar binders are precisely-           -- the universals followed by the existentials.-           -- See Note [DataCon user type variable binders] in DataCon.-           user_tvbs = univ_tvbs ++ ex_tvbs-           buildOneDataCon (dL->L _ name) = do-             { is_infix <- tcConIsInfixH98 name hs_args-             ; rep_nm   <- newTyConRepName name--             ; buildDataCon fam_envs name is_infix rep_nm-                            stricts Nothing field_lbls-                            univ_tvs ex_tvs user_tvbs-                            [{- no eq_preds -}] ctxt arg_tys-                            res_tmpl rep_tycon tag_map-                  -- NB:  we put data_tc, the type constructor gotten from the-                  --      constructor type signature into the data constructor;-                  --      that way checkValidDataCon can complain if it's wrong.-             }-       ; traceTc "tcConDecl 2" (ppr name)-       ; mapM buildOneDataCon [name]-       }--tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl-          (ConDeclGADT { con_names = names-                       , con_qvars = qtvs-                       , con_mb_cxt = cxt, con_args = hs_args-                       , con_res_ty = hs_res_ty })-  | HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = implicit_tkv_nms }-           , hsq_explicit = explicit_tkv_nms } <- qtvs-  = addErrCtxt (dataConCtxtName names) $-    do { traceTc "tcConDecl 1 gadt" (ppr names)-       ; let ((dL->L _ name) : _) = names--       ; (imp_tvs, (exp_tvs, (ctxt, arg_tys, res_ty, field_lbls, stricts)))-           <- pushTcLevelM_    $  -- We are going to generalise-              solveEqualities  $  -- We won't get another crack, and we don't-                                  -- want an error cascade-              bindImplicitTKBndrs_Skol implicit_tkv_nms $-              bindExplicitTKBndrs_Skol explicit_tkv_nms $-              do { ctxt <- tcHsMbContext cxt-                 ; btys <- tcConArgs hs_args-                 ; res_ty <- tcHsLiftedType hs_res_ty-                 ; field_lbls <- lookupConstructorFields name-                 ; let (arg_tys, stricts) = unzip btys-                 ; return (ctxt, arg_tys, res_ty, field_lbls, stricts)-                 }-       ; imp_tvs <- zonkAndScopedSort imp_tvs-       ; let user_tvs = imp_tvs ++ exp_tvs--       ; tkvs <- kindGeneralize (mkSpecForAllTys user_tvs $-                                 mkFunTys ctxt $-                                 mkFunTys arg_tys $-                                 res_ty)--             -- Zonk to Types-       ; (ze, tkvs)     <- zonkTyBndrs tkvs-       ; (ze, user_tvs) <- zonkTyBndrsX ze user_tvs-       ; arg_tys <- zonkTcTypesToTypesX ze arg_tys-       ; ctxt    <- zonkTcTypesToTypesX ze ctxt-       ; res_ty  <- zonkTcTypeToTypeX   ze res_ty--       ; let (univ_tvs, ex_tvs, tkvs', user_tvs', eq_preds, arg_subst)-               = rejigConRes tmpl_bndrs res_tmpl tkvs user_tvs res_ty-             -- NB: this is a /lazy/ binding, so we pass six thunks to-             --     buildDataCon without yet forcing the guards in rejigConRes-             -- See Note [Checking GADT return types]--             -- Compute the user-written tyvar binders. These have the same-             -- tyvars as univ_tvs/ex_tvs, but perhaps in a different order.-             -- See Note [DataCon user type variable binders] in DataCon.-             tkv_bndrs      = mkTyVarBinders Inferred  tkvs'-             user_tv_bndrs  = mkTyVarBinders Specified user_tvs'-             all_user_bndrs = tkv_bndrs ++ user_tv_bndrs--             ctxt'      = substTys arg_subst ctxt-             arg_tys'   = substTys arg_subst arg_tys-             res_ty'    = substTy  arg_subst res_ty---       ; fam_envs <- tcGetFamInstEnvs--       -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here-       ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls)-       ; let-           buildOneDataCon (dL->L _ name) = do-             { is_infix <- tcConIsInfixGADT name hs_args-             ; rep_nm   <- newTyConRepName name--             ; buildDataCon fam_envs name is_infix-                            rep_nm-                            stricts Nothing field_lbls-                            univ_tvs ex_tvs all_user_bndrs eq_preds-                            ctxt' arg_tys' res_ty' rep_tycon tag_map-                  -- NB:  we put data_tc, the type constructor gotten from the-                  --      constructor type signature into the data constructor;-                  --      that way checkValidDataCon can complain if it's wrong.-             }-       ; traceTc "tcConDecl 2" (ppr names)-       ; mapM buildOneDataCon names-       }-tcConDecl _ _ _ _ (ConDeclGADT _ _ _ (XLHsQTyVars _) _ _ _ _)-  = panic "tcConDecl"-tcConDecl _ _ _ _ (XConDecl _) = panic "tcConDecl"--tcConIsInfixH98 :: Name-             -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])-             -> TcM Bool-tcConIsInfixH98 _   details-  = case details of-           InfixCon {}  -> return True-           _            -> return False--tcConIsInfixGADT :: Name-             -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])-             -> TcM Bool-tcConIsInfixGADT con details-  = case details of-           InfixCon {}  -> return True-           RecCon {}    -> return False-           PrefixCon arg_tys           -- See Note [Infix GADT constructors]-               | isSymOcc (getOccName con)-               , [_ty1,_ty2] <- arg_tys-                  -> do { fix_env <- getFixityEnv-                        ; return (con `elemNameEnv` fix_env) }-               | otherwise -> return False--tcConArgs :: HsConDeclDetails GhcRn-          -> TcM [(TcType, HsSrcBang)]-tcConArgs (PrefixCon btys)-  = mapM tcConArg btys-tcConArgs (InfixCon bty1 bty2)-  = do { bty1' <- tcConArg bty1-       ; bty2' <- tcConArg bty2-       ; return [bty1', bty2'] }-tcConArgs (RecCon fields)-  = mapM tcConArg btys-  where-    -- We need a one-to-one mapping from field_names to btys-    combined = map (\(dL->L _ f) -> (cd_fld_names f,cd_fld_type f))-                   (unLoc fields)-    explode (ns,ty) = zip ns (repeat ty)-    exploded = concatMap explode combined-    (_,btys) = unzip exploded---tcConArg :: LHsType GhcRn -> TcM (TcType, HsSrcBang)-tcConArg bty-  = do  { traceTc "tcConArg 1" (ppr bty)-        ; arg_ty <- tcHsOpenType (getBangType bty)-             -- Newtypes can't have unboxed types, but we check-             -- that in checkValidDataCon; this tcConArg stuff-             -- doesn't happen for GADT-style declarations-        ; traceTc "tcConArg 2" (ppr bty)-        ; return (arg_ty, getBangStrictness bty) }--{--Note [Infix GADT constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We do not currently have syntax to declare an infix constructor in GADT syntax,-but it makes a (small) difference to the Show instance.  So as a slightly-ad-hoc solution, we regard a GADT data constructor as infix if-  a) it is an operator symbol-  b) it has two arguments-  c) there is a fixity declaration for it-For example:-   infix 6 (:--:)-   data T a where-     (:--:) :: t1 -> t2 -> T Int---Note [Checking GADT return types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There is a delicacy around checking the return types of a datacon. The-central problem is dealing with a declaration like--  data T a where-    MkT :: T a -> Q a--Note that the return type of MkT is totally bogus. When creating the T-tycon, we also need to create the MkT datacon, which must have a "rejigged"-return type. That is, the MkT datacon's type must be transformed to have-a uniform return type with explicit coercions for GADT-like type parameters.-This rejigging is what rejigConRes does. The problem is, though, that checking-that the return type is appropriate is much easier when done over *Type*,-not *HsType*, and doing a call to tcMatchTy will loop because T isn't fully-defined yet.--So, we want to make rejigConRes lazy and then check the validity of-the return type in checkValidDataCon.  To do this we /always/ return a-6-tuple from rejigConRes (so that we can compute the return type from it, which-checkValidDataCon needs), but the first three fields may be bogus if-the return type isn't valid (the last equation for rejigConRes).--This is better than an earlier solution which reduced the number of-errors reported in one pass.  See Trac #7175, and #10836.--}---- Example---   data instance T (b,c) where---      TI :: forall e. e -> T (e,e)------ The representation tycon looks like this:---   data :R7T b c where---      TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1--- In this case orig_res_ty = T (e,e)--rejigConRes :: [KnotTied TyConBinder] -> KnotTied Type    -- Template for result type; e.g.-                                  -- data instance T [a] b c ...-                                  --      gives template ([a,b,c], T [a] b c)-                                  -- Type must be of kind *!-            -> [TyVar]            -- The constructor's inferred type variables-            -> [TyVar]            -- The constructor's user-written, specified-                                  -- type variables-            -> KnotTied Type      -- res_ty type must be of kind *-            -> ([TyVar],          -- Universal-                [TyVar],          -- Existential (distinct OccNames from univs)-                [TyVar],          -- The constructor's rejigged, user-written,-                                  -- inferred type variables-                [TyVar],          -- The constructor's rejigged, user-written,-                                  -- specified type variables-                [EqSpec],      -- Equality predicates-                TCvSubst)      -- Substitution to apply to argument types-        -- We don't check that the TyCon given in the ResTy is-        -- the same as the parent tycon, because checkValidDataCon will do it--- NB: All arguments may potentially be knot-tied-rejigConRes tmpl_bndrs res_tmpl dc_inferred_tvs dc_specified_tvs res_ty-        -- E.g.  data T [a] b c where-        --         MkT :: forall x y z. T [(x,y)] z z-        -- The {a,b,c} are the tmpl_tvs, and the {x,y,z} are the dc_tvs-        --     (NB: unlike the H98 case, the dc_tvs are not all existential)-        -- Then we generate-        --      Univ tyvars     Eq-spec-        --          a              a~(x,y)-        --          b              b~z-        --          z-        -- Existentials are the leftover type vars: [x,y]-        -- The user-written type variables are what is listed in the forall:-        --   [x, y, z] (all specified). We must rejig these as well.-        --   See Note [DataCon user type variable binders] in DataCon.-        -- So we return ( [a,b,z], [x,y]-        --              , [], [x,y,z]-        --              , [a~(x,y),b~z], <arg-subst> )-  | Just subst <- ASSERT( isLiftedTypeKind (tcTypeKind res_ty) )-                  ASSERT( isLiftedTypeKind (tcTypeKind res_tmpl) )-                  tcMatchTy res_tmpl res_ty-  = let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tmpl_tvs dc_tvs subst-        raw_ex_tvs = dc_tvs `minusList` univ_tvs-        (arg_subst, substed_ex_tvs) = substTyVarBndrs kind_subst raw_ex_tvs--        -- After rejigging the existential tyvars, the resulting substitution-        -- gives us exactly what we need to rejig the user-written tyvars,-        -- since the dcUserTyVarBinders invariant guarantees that the-        -- substitution has *all* the tyvars in its domain.-        -- See Note [DataCon user type variable binders] in DataCon.-        subst_user_tvs = map (getTyVar "rejigConRes" . substTyVar arg_subst)-        substed_inferred_tvs  = subst_user_tvs dc_inferred_tvs-        substed_specified_tvs = subst_user_tvs dc_specified_tvs--        substed_eqs = map (substEqSpec arg_subst) raw_eqs-    in-    (univ_tvs, substed_ex_tvs, substed_inferred_tvs, substed_specified_tvs,-     substed_eqs, arg_subst)--  | otherwise-        -- If the return type of the data constructor doesn't match the parent-        -- type constructor, or the arity is wrong, the tcMatchTy will fail-        --    e.g   data T a b where-        --            T1 :: Maybe a   -- Wrong tycon-        --            T2 :: T [a]     -- Wrong arity-        -- We are detect that later, in checkValidDataCon, but meanwhile-        -- we must do *something*, not just crash.  So we do something simple-        -- albeit bogus, relying on checkValidDataCon to check the-        --  bad-result-type error before seeing that the other fields look odd-        -- See Note [Checking GADT return types]-  = (tmpl_tvs, dc_tvs `minusList` tmpl_tvs, dc_inferred_tvs, dc_specified_tvs,-     [], emptyTCvSubst)-  where-    dc_tvs   = dc_inferred_tvs ++ dc_specified_tvs-    tmpl_tvs = binderVars tmpl_bndrs--{- Note [mkGADTVars]-~~~~~~~~~~~~~~~~~~~~-Running example:--data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where-  MkT :: forall (x1 : *) (y :: x1) (z :: *).-         T x1 * (Proxy (y :: x1), z) z--We need the rejigged type to be--  MkT :: forall (x1 :: *) (k2 :: *) (a :: k2) (b :: k2).-         forall (y :: x1) (z :: *).-         (k2 ~ *, a ~ (Proxy x1 y, z), b ~ z)-      => T x1 k2 a b--You might naively expect that z should become a universal tyvar,-not an existential. (After all, x1 becomes a universal tyvar.)-But z has kind * while b has kind k2, so the return type-   T x1 k2 a z-is ill-kinded.  Another way to say it is this: the universal-tyvars must have exactly the same kinds as the tyConTyVars.--So we need an existential tyvar and a heterogeneous equality-constraint. (The b ~ z is a bit redundant with the k2 ~ * that-comes before in that b ~ z implies k2 ~ *. I'm sure we could do-some analysis that could eliminate k2 ~ *. But we don't do this-yet.)--The data con signature has already been fully kind-checked.-The return type--  T x1 * (Proxy (y :: x1), z) z-becomes-  qtkvs    = [x1 :: *, y :: x1, z :: *]-  res_tmpl = T x1 * (Proxy x1 y, z) z--We start off by matching (T k1 k2 a b) with (T x1 * (Proxy x1 y, z) z). We-know this match will succeed because of the validity check (actually done-later, but laziness saves us -- see Note [Checking GADT return types]).-Thus, we get--  subst := { k1 |-> x1, k2 |-> *, a |-> (Proxy x1 y, z), b |-> z }--Now, we need to figure out what the GADT equalities should be. In this case,-we *don't* want (k1 ~ x1) to be a GADT equality: it should just be a-renaming. The others should be GADT equalities. We also need to make-sure that the universally-quantified variables of the datacon match up-with the tyvars of the tycon, as required for Core context well-formedness.-(This last bit is why we have to rejig at all!)--`choose` walks down the tycon tyvars, figuring out what to do with each one.-It carries two substitutions:-  - t_sub's domain is *template* or *tycon* tyvars, mapping them to variables-    mentioned in the datacon signature.-  - r_sub's domain is *result* tyvars, names written by the programmer in-    the datacon signature. The final rejigged type will use these names, but-    the subst is still needed because sometimes the printed name of these variables-    is different. (See choose_tv_name, below.)--Before explaining the details of `choose`, let's just look at its operation-on our example:--  choose [] [] {} {} [k1, k2, a, b]-  -->          -- first branch of `case` statement-  choose-    univs:    [x1 :: *]-    eq_spec:  []-    t_sub:    {k1 |-> x1}-    r_sub:    {x1 |-> x1}-    t_tvs:    [k2, a, b]-  -->          -- second branch of `case` statement-  choose-    univs:    [k2 :: *, x1 :: *]-    eq_spec:  [k2 ~ *]-    t_sub:    {k1 |-> x1, k2 |-> k2}-    r_sub:    {x1 |-> x1}-    t_tvs:    [a, b]-  -->          -- second branch of `case` statement-  choose-    univs:    [a :: k2, k2 :: *, x1 :: *]-    eq_spec:  [ a ~ (Proxy x1 y, z)-              , k2 ~ * ]-    t_sub:    {k1 |-> x1, k2 |-> k2, a |-> a}-    r_sub:    {x1 |-> x1}-    t_tvs:    [b]-  -->          -- second branch of `case` statement-  choose-    univs:    [b :: k2, a :: k2, k2 :: *, x1 :: *]-    eq_spec:  [ b ~ z-              , a ~ (Proxy x1 y, z)-              , k2 ~ * ]-    t_sub:    {k1 |-> x1, k2 |-> k2, a |-> a, b |-> z}-    r_sub:    {x1 |-> x1}-    t_tvs:    []-  -->          -- end of recursion-  ( [x1 :: *, k2 :: *, a :: k2, b :: k2]-  , [k2 ~ *, a ~ (Proxy x1 y, z), b ~ z]-  , {x1 |-> x1} )--`choose` looks up each tycon tyvar in the matching (it *must* be matched!).--* If it finds a bare result tyvar (the first branch of the `case`-  statement), it checks to make sure that the result tyvar isn't yet-  in the list of univ_tvs.  If it is in that list, then we have a-  repeated variable in the return type, and we in fact need a GADT-  equality.--* It then checks to make sure that the kind of the result tyvar-  matches the kind of the template tyvar. This check is what forces-  `z` to be existential, as it should be, explained above.--* Assuming no repeated variables or kind-changing, we wish to use the-  variable name given in the datacon signature (that is, `x1` not-  `k1`), not the tycon signature (which may have been made up by-  GHC). So, we add a mapping from the tycon tyvar to the result tyvar-  to t_sub.--* If we discover that a mapping in `subst` gives us a non-tyvar (the-  second branch of the `case` statement), then we have a GADT equality-  to create.  We create a fresh equality, but we don't extend any-  substitutions. The template variable substitution is meant for use-  in universal tyvar kinds, and these shouldn't be affected by any-  GADT equalities.--This whole algorithm is quite delicate, indeed. I (Richard E.) see two ways-of simplifying it:--1) The first branch of the `case` statement is really an optimization, used-in order to get fewer GADT equalities. It might be possible to make a GADT-equality for *every* univ. tyvar, even if the equality is trivial, and then-either deal with the bigger type or somehow reduce it later.--2) This algorithm strives to use the names for type variables as specified-by the user in the datacon signature. If we always used the tycon tyvar-names, for example, this would be simplified. This change would almost-certainly degrade error messages a bit, though.--}---- ^ From information about a source datacon definition, extract out--- what the universal variables and the GADT equalities should be.--- See Note [mkGADTVars].-mkGADTVars :: [TyVar]    -- ^ The tycon vars-           -> [TyVar]    -- ^ The datacon vars-           -> TCvSubst   -- ^ The matching between the template result type-                         -- and the actual result type-           -> ( [TyVar]-              , [EqSpec]-              , TCvSubst ) -- ^ The univ. variables, the GADT equalities,-                           -- and a subst to apply to the GADT equalities-                           -- and existentials.-mkGADTVars tmpl_tvs dc_tvs subst-  = choose [] [] empty_subst empty_subst tmpl_tvs-  where-    in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs)-               `unionInScope` getTCvInScope subst-    empty_subst = mkEmptyTCvSubst in_scope--    choose :: [TyVar]           -- accumulator of univ tvs, reversed-           -> [EqSpec]          -- accumulator of GADT equalities, reversed-           -> TCvSubst          -- template substitution-           -> TCvSubst          -- res. substitution-           -> [TyVar]           -- template tvs (the univ tvs passed in)-           -> ( [TyVar]         -- the univ_tvs-              , [EqSpec]        -- GADT equalities-              , TCvSubst )       -- a substitution to fix kinds in ex_tvs--    choose univs eqs _t_sub r_sub []-      = (reverse univs, reverse eqs, r_sub)-    choose univs eqs t_sub r_sub (t_tv:t_tvs)-      | Just r_ty <- lookupTyVar subst t_tv-      = case getTyVar_maybe r_ty of-          Just r_tv-            |  not (r_tv `elem` univs)-            ,  tyVarKind r_tv `eqType` (substTy t_sub (tyVarKind t_tv))-            -> -- simple, well-kinded variable substitution.-               choose (r_tv:univs) eqs-                      (extendTvSubst t_sub t_tv r_ty')-                      (extendTvSubst r_sub r_tv r_ty')-                      t_tvs-            where-              r_tv1  = setTyVarName r_tv (choose_tv_name r_tv t_tv)-              r_ty'  = mkTyVarTy r_tv1--               -- Not a simple substitution: make an equality predicate-          _ -> choose (t_tv':univs) (mkEqSpec t_tv' r_ty : eqs)-                      (extendTvSubst t_sub t_tv (mkTyVarTy t_tv'))-                         -- We've updated the kind of t_tv,-                         -- so add it to t_sub (Trac #14162)-                      r_sub t_tvs-            where-              t_tv' = updateTyVarKind (substTy t_sub) t_tv--      | otherwise-      = pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst)--      -- choose an appropriate name for a univ tyvar.-      -- This *must* preserve the Unique of the result tv, so that we-      -- can detect repeated variables. It prefers user-specified names-      -- over system names. A result variable with a system name can-      -- happen with GHC-generated implicit kind variables.-    choose_tv_name :: TyVar -> TyVar -> Name-    choose_tv_name r_tv t_tv-      | isSystemName r_tv_name-      = setNameUnique t_tv_name (getUnique r_tv_name)--      | otherwise-      = r_tv_name--      where-        r_tv_name = getName r_tv-        t_tv_name = getName t_tv--{--Note [Substitution in template variables kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--data G (a :: Maybe k) where-  MkG :: G Nothing--With explicit kind variables--data G k (a :: Maybe k) where-  MkG :: G k1 (Nothing k1)--Note how k1 is distinct from k. So, when we match the template-`G k a` against `G k1 (Nothing k1)`, we get a subst-[ k |-> k1, a |-> Nothing k1 ]. Even though this subst has two-mappings, we surely don't want to add (k, k1) to the list of-GADT equalities -- that would be overly complex and would create-more untouchable variables than we need. So, when figuring out-which tyvars are GADT-like and which aren't (the fundamental-job of `choose`), we want to treat `k` as *not* GADT-like.-Instead, we wish to substitute in `a`'s kind, to get (a :: Maybe k1)-instead of (a :: Maybe k). This is the reason for dealing-with a substitution in here.--However, we do not *always* want to substitute. Consider--data H (a :: k) where-  MkH :: H Int--With explicit kind variables:--data H k (a :: k) where-  MkH :: H * Int--Here, we have a kind-indexed GADT. The subst in question is-[ k |-> *, a |-> Int ]. Now, we *don't* want to substitute in `a`'s-kind, because that would give a constructor with the type--MkH :: forall (k :: *) (a :: *). (k ~ *) -> (a ~ Int) -> H k a--The problem here is that a's kind is wrong -- it needs to be k, not *!-So, if the matching for a variable is anything but another bare variable,-we drop the mapping from the substitution before proceeding. This-was not an issue before kind-indexed GADTs because this case could-never happen.--************************************************************************-*                                                                      *-                Validity checking-*                                                                      *-************************************************************************--Validity checking is done once the mutually-recursive knot has been-tied, so we can look at things freely.--}--checkValidTyCl :: TyCon -> TcM [TyCon]--- The returned list is either a singleton (if valid)--- or a list of "fake tycons" (if not); the fake tycons--- include any implicits, like promoted data constructors--- See Note [Recover from validity error]-checkValidTyCl tc-  = setSrcSpan (getSrcSpan tc) $-    addTyConCtxt tc $-    recoverM recovery_code-             (do { traceTc "Starting validity for tycon" (ppr tc)-                 ; checkValidTyCon tc-                 ; traceTc "Done validity for tycon" (ppr tc)-                 ; return [tc] })-  where-    recovery_code -- See Note [Recover from validity error]-      = do { traceTc "Aborted validity for tycon" (ppr tc)-           ; return (concatMap mk_fake_tc $-                     ATyCon tc : implicitTyConThings tc) }--    mk_fake_tc (ATyCon tc)-      | isClassTyCon tc = [tc]   -- Ugh! Note [Recover from validity error]-      | otherwise       = [makeRecoveryTyCon tc]-    mk_fake_tc (AConLike (RealDataCon dc))-                        = [makeRecoveryTyCon (promoteDataCon dc)]-    mk_fake_tc _        = []--{- Note [Recover from validity error]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We recover from a validity error in a type or class, which allows us-to report multiple validity errors. In the failure case we return a-TyCon of the right kind, but with no interesting behaviour-(makeRecoveryTyCon). Why?  Suppose we have-   type T a = Fun-where Fun is a type family of arity 1.  The RHS is invalid, but we-want to go on checking validity of subsequent type declarations.-So we replace T with an abstract TyCon which will do no harm.-See indexed-types/should_fail/BadSock and Trac #10896--Some notes:--* We must make fakes for promoted DataCons too. Consider (Trac #15215)-      data T a = MkT ...-      data S a = ...T...MkT....-  If there is an error in the definition of 'T' we add a "fake type-  constructor" to the type environment, so that we can continue to-  typecheck 'S'.  But we /were not/ adding a fake anything for 'MkT'-  and so there was an internal error when we met 'MkT' in the body of-  'S'.--* Painfully, we *don't* want to do this for classes.-  Consider tcfail041:-     class (?x::Int) => C a where ...-     instance C Int-  The class is invalid because of the superclass constraint.  But-  we still want it to look like a /class/, else the instance bleats-  that the instance is mal-formed because it hasn't got a class in-  the head.--  This is really bogus; now we have in scope a Class that is invalid-  in some way, with unknown downstream consequences.  A better-  alterantive might be to make a fake class TyCon.  A job for another day.--}------------------------------ For data types declared with record syntax, we require--- that each constructor that has a field 'f'---      (a) has the same result type---      (b) has the same type for 'f'--- module alpha conversion of the quantified type variables--- of the constructor.------ Note that we allow existentials to match because the--- fields can never meet. E.g---      data T where---        T1 { f1 :: b, f2 :: a, f3 ::Int } :: T---        T2 { f1 :: c, f2 :: c, f3 ::Int } :: T--- Here we do not complain about f1,f2 because they are existential--checkValidTyCon :: TyCon -> TcM ()-checkValidTyCon tc-  | isPrimTyCon tc   -- Happens when Haddock'ing GHC.Prim-  = return ()--  | otherwise-  = do { traceTc "checkValidTyCon" (ppr tc $$ ppr (tyConClass_maybe tc))-       ; if | Just cl <- tyConClass_maybe tc-              -> checkValidClass cl--            | Just syn_rhs <- synTyConRhs_maybe tc-              -> do { checkValidType syn_ctxt syn_rhs-                    ; checkTySynRhs syn_ctxt syn_rhs }--            | Just fam_flav <- famTyConFlav_maybe tc-              -> case fam_flav of-               { ClosedSynFamilyTyCon (Just ax)-                   -> tcAddClosedTypeFamilyDeclCtxt tc $-                      checkValidCoAxiom ax-               ; ClosedSynFamilyTyCon Nothing   -> return ()-               ; AbstractClosedSynFamilyTyCon ->-                 do { hsBoot <- tcIsHsBootOrSig-                    ; checkTc hsBoot $-                      text "You may define an abstract closed type family" $$-                      text "only in a .hs-boot file" }-               ; DataFamilyTyCon {}           -> return ()-               ; OpenSynFamilyTyCon           -> return ()-               ; BuiltInSynFamTyCon _         -> return () }--             | otherwise -> do-               { -- Check the context on the data decl-                 traceTc "cvtc1" (ppr tc)-               ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)--               ; traceTc "cvtc2" (ppr tc)--               ; dflags          <- getDynFlags-               ; existential_ok  <- xoptM LangExt.ExistentialQuantification-               ; gadt_ok         <- xoptM LangExt.GADTs-               ; let ex_ok = existential_ok || gadt_ok-                     -- Data cons can have existential context-               ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons-               ; mapM_ (checkPartialRecordField data_cons) (tyConFieldLabels tc)--                -- Check that fields with the same name share a type-               ; mapM_ check_fields groups }}-  where-    syn_ctxt  = TySynCtxt name-    name      = tyConName tc-    data_cons = tyConDataCons tc--    groups = equivClasses cmp_fld (concatMap get_fields data_cons)-    cmp_fld (f1,_) (f2,_) = flLabel f1 `compare` flLabel f2-    get_fields con = dataConFieldLabels con `zip` repeat con-        -- dataConFieldLabels may return the empty list, which is fine--    -- See Note [GADT record selectors] in TcTyDecls-    -- We must check (a) that the named field has the same-    --                   type in each constructor-    --               (b) that those constructors have the same result type-    ---    -- However, the constructors may have differently named type variable-    -- and (worse) we don't know how the correspond to each other.  E.g.-    --     C1 :: forall a b. { f :: a, g :: b } -> T a b-    --     C2 :: forall d c. { f :: c, g :: c } -> T c d-    ---    -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's-    -- result type against other candidates' types BOTH WAYS ROUND.-    -- If they magically agrees, take the substitution and-    -- apply them to the latter ones, and see if they match perfectly.-    check_fields ((label, con1) :| other_fields)-        -- These fields all have the same name, but are from-        -- different constructors in the data type-        = recoverM (return ()) $ mapM_ checkOne other_fields-                -- Check that all the fields in the group have the same type-                -- NB: this check assumes that all the constructors of a given-                -- data type use the same type variables-        where-        (_, _, _, res1) = dataConSig con1-        fty1 = dataConFieldType con1 lbl-        lbl = flLabel label--        checkOne (_, con2)    -- Do it both ways to ensure they are structurally identical-            = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2-                 ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 }-            where-                (_, _, _, res2) = dataConSig con2-                fty2 = dataConFieldType con2 lbl--checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM ()--- Checks the partial record field selector, and warns.--- See Note [Checking partial record field]-checkPartialRecordField all_cons fld-  = setSrcSpan loc $-      warnIfFlag Opt_WarnPartialFields-        (not is_exhaustive && not (startsWithUnderscore occ_name))-        (sep [text "Use of partial record field selector" <> colon,-              nest 2 $ quotes (ppr occ_name)])-  where-    sel_name = flSelector fld-    loc    = getSrcSpan sel_name-    occ_name = getOccName sel_name--    (cons_with_field, cons_without_field) = partition has_field all_cons-    has_field con = fld `elem` (dataConFieldLabels con)-    is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field--    con1 = ASSERT( not (null cons_with_field) ) head cons_with_field-    (univ_tvs, _, eq_spec, _, _, _) = dataConFullSig con1-    eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec)-    inst_tys = substTyVars eq_subst univ_tvs--checkFieldCompat :: FieldLabelString -> DataCon -> DataCon-                 -> Type -> Type -> Type -> Type -> TcM ()-checkFieldCompat fld con1 con2 res1 res2 fty1 fty2-  = do  { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2)-        ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) }-  where-    mb_subst1 = tcMatchTy res1 res2-    mb_subst2 = tcMatchTyX (expectJust "checkFieldCompat" mb_subst1) fty1 fty2----------------------------------checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM ()-checkValidDataCon dflags existential_ok tc con-  = setSrcSpan (getSrcSpan con)  $-    addErrCtxt (dataConCtxt con) $-    do  { -- Check that the return type of the data constructor-          -- matches the type constructor; eg reject this:-          --   data T a where { MkT :: Bogus a }-          -- It's important to do this first:-          --  see Note [Checking GADT return types]-          --  and c.f. Note [Check role annotations in a second pass]-          let tc_tvs      = tyConTyVars tc-              res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)-              orig_res_ty = dataConOrigResTy con-        ; traceTc "checkValidDataCon" (vcat-              [ ppr con, ppr tc, ppr tc_tvs-              , ppr res_ty_tmpl <+> dcolon <+> ppr (tcTypeKind res_ty_tmpl)-              , ppr orig_res_ty <+> dcolon <+> ppr (tcTypeKind orig_res_ty)])---        ; checkTc (isJust (tcMatchTy res_ty_tmpl-                                     orig_res_ty))-                  (badDataConTyCon con res_ty_tmpl orig_res_ty)-            -- Note that checkTc aborts if it finds an error. This is-            -- critical to avoid panicking when we call dataConUserType-            -- on an un-rejiggable datacon!--        ; traceTc "checkValidDataCon 2" (ppr (dataConUserType con))--          -- Check that the result type is a *monotype*-          --  e.g. reject this:   MkT :: T (forall a. a->a)-          -- Reason: it's really the argument of an equality constraint-        ; checkValidMonoType orig_res_ty--          -- Check all argument types for validity-        ; checkValidType ctxt (dataConUserType con)-        ; mapM_ (checkForLevPoly empty)-                (dataConOrigArgTys con)--          -- Extra checks for newtype data constructors-        ; when (isNewTyCon tc) (checkNewDataCon con)--          -- Check that existentials are allowed if they are used-        ; checkTc (existential_ok || isVanillaDataCon con)-                  (badExistential con)--          -- Check that UNPACK pragmas and bangs work out-          -- E.g.  reject   data T = MkT {-# UNPACK #-} Int     -- No "!"-          --                data T = MkT {-# UNPACK #-} !a      -- Can't unpack-        ; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..]--          -- Check the dcUserTyVarBinders invariant-          -- See Note [DataCon user type variable binders] in DataCon-          -- checked here because we sometimes build invalid DataCons before-          -- erroring above here-        ; when debugIsOn $-          do { let (univs, exs, eq_spec, _, _, _) = dataConFullSig con-                   user_tvs                       = dataConUserTyVars con-                   user_tvbs_invariant-                     =    Set.fromList (filterEqSpec eq_spec univs ++ exs)-                       == Set.fromList user_tvs-             ; WARN( not user_tvbs_invariant-                       , vcat ([ ppr con-                               , ppr univs-                               , ppr exs-                               , ppr eq_spec-                               , ppr user_tvs ])) return () }--        ; traceTc "Done validity of data con" $-          vcat [ ppr con-               , text "Datacon user type:" <+> ppr (dataConUserType con)-               , text "Datacon rep type:" <+> ppr (dataConRepType con)-               , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con))-               , case tyConFamInst_maybe (dataConTyCon con) of-                   Nothing -> text "not family"-                   Just (f, _) -> ppr (tyConBinders f) ]-    }-  where-    ctxt = ConArgCtxt (dataConName con)--    check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM ()-    check_bang (HsSrcBang _ _ SrcLazy) _ n-      | not (xopt LangExt.StrictData dflags)-      = addErrTc-          (bad_bang n (text "Lazy annotation (~) without StrictData"))-    check_bang (HsSrcBang _ want_unpack strict_mark) rep_bang n-      | isSrcUnpacked want_unpack, not is_strict-      = addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'"))-      | isSrcUnpacked want_unpack-      , case rep_bang of { HsUnpack {} -> False; _ -> True }-      -- If not optimising, we don't unpack (rep_bang is never-      -- HsUnpack), so don't complain!  This happens, e.g., in Haddock.-      -- See dataConSrcToImplBang.-      , not (gopt Opt_OmitInterfacePragmas dflags)-      -- When typechecking an indefinite package in Backpack, we-      -- may attempt to UNPACK an abstract type.  The test here will-      -- conclude that this is unusable, but it might become usable-      -- when we actually fill in the abstract type.  As such, don't-      -- warn in this case (it gives users the wrong idea about whether-      -- or not UNPACK on abstract types is supported; it is!)-      , unitIdIsDefinite (thisPackage dflags)-      = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma"))-      where-        is_strict = case strict_mark of-                      NoSrcStrict -> xopt LangExt.StrictData dflags-                      bang        -> isSrcStrict bang--    check_bang _ _ _-      = return ()--    bad_bang n herald-      = hang herald 2 (text "on the" <+> speakNth n-                       <+> text "argument of" <+> quotes (ppr con))---------------------------------checkNewDataCon :: DataCon -> TcM ()--- Further checks for the data constructor of a newtype-checkNewDataCon con-  = do  { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys))-              -- One argument--        ; checkTc (not (isUnliftedType arg_ty1)) $-          text "A newtype cannot have an unlifted argument type"--        ; check_con (null eq_spec) $-          text "A newtype constructor must have a return type of form T a1 ... an"-                -- Return type is (T a b c)--        ; check_con (null theta) $-          text "A newtype constructor cannot have a context in its type"--        ; check_con (null ex_tvs) $-          text "A newtype constructor cannot have existential type variables"-                -- No existentials--        ; checkTc (all ok_bang (dataConSrcBangs con))-                  (newtypeStrictError con)-                -- No strictness annotations-    }-  where-    (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)-      = dataConFullSig con-    check_con what msg-       = checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConUserType con))--    (arg_ty1 : _) = arg_tys--    ok_bang (HsSrcBang _ _ SrcStrict) = False-    ok_bang (HsSrcBang _ _ SrcLazy)   = False-    ok_bang _                         = True----------------------------------checkValidClass :: Class -> TcM ()-checkValidClass cls-  = do  { constrained_class_methods <- xoptM LangExt.ConstrainedClassMethods-        ; multi_param_type_classes  <- xoptM LangExt.MultiParamTypeClasses-        ; nullary_type_classes      <- xoptM LangExt.NullaryTypeClasses-        ; fundep_classes            <- xoptM LangExt.FunctionalDependencies-        ; undecidable_super_classes <- xoptM LangExt.UndecidableSuperClasses--        -- Check that the class is unary, unless multiparameter type classes-        -- are enabled; also recognize deprecated nullary type classes-        -- extension (subsumed by multiparameter type classes, Trac #8993)-        ; checkTc (multi_param_type_classes || cls_arity == 1 ||-                    (nullary_type_classes && cls_arity == 0))-                  (classArityErr cls_arity cls)-        ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls)--        -- Check the super-classes-        ; checkValidTheta (ClassSCCtxt (className cls)) theta--          -- Now check for cyclic superclasses-          -- If there are superclass cycles, checkClassCycleErrs bails.-        ; unless undecidable_super_classes $-          case checkClassCycles cls of-             Just err -> setSrcSpan (getSrcSpan cls) $-                         addErrTc err-             Nothing  -> return ()--        -- Check the class operations.-        -- But only if there have been no earlier errors-        -- See Note [Abort when superclass cycle is detected]-        ; whenNoErrs $-          mapM_ (check_op constrained_class_methods) op_stuff--        -- Check the associated type defaults are well-formed and instantiated-        ; mapM_ check_at at_stuff  }-  where-    (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls-    cls_arity = length (tyConVisibleTyVars (classTyCon cls))-       -- Ignore invisible variables-    cls_tv_set = mkVarSet tyvars--    check_op constrained_class_methods (sel_id, dm)-      = setSrcSpan (getSrcSpan sel_id) $-        addErrCtxt (classOpCtxt sel_id op_ty) $ do-        { traceTc "class op type" (ppr op_ty)-        ; checkValidType ctxt op_ty-                -- This implements the ambiguity check, among other things-                -- Example: tc223-                --   class Error e => Game b mv e | b -> mv e where-                --      newBoard :: MonadState b m => m ()-                -- Here, MonadState has a fundep m->b, so newBoard is fine--           -- a method cannot be levity polymorphic, as we have to store the-           -- method in a dictionary-           -- example of what this prevents:-           --   class BoundedX (a :: TYPE r) where minBound :: a-           -- See Note [Levity polymorphism checking] in DsMonad-        ; checkForLevPoly empty tau1--        ; unless constrained_class_methods $-          mapM_ check_constraint (tail (cls_pred:op_theta))--        ; check_dm ctxt sel_id cls_pred tau2 dm-        }-        where-          ctxt    = FunSigCtxt op_name True -- Report redundant class constraints-          op_name = idName sel_id-          op_ty   = idType sel_id-          (_,cls_pred,tau1) = tcSplitMethodTy op_ty-          -- See Note [Splitting nested sigma types in class type signatures]-          (_,op_theta,tau2) = tcSplitNestedSigmaTys tau1--          check_constraint :: TcPredType -> TcM ()-          check_constraint pred -- See Note [Class method constraints]-            = when (not (isEmptyVarSet pred_tvs) &&-                    pred_tvs `subVarSet` cls_tv_set)-                   (addErrTc (badMethPred sel_id pred))-            where-              pred_tvs = tyCoVarsOfType pred--    check_at (ATI fam_tc m_dflt_rhs)-      = do { checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs)-                     (noClassTyVarErr cls fam_tc)-                        -- Check that the associated type mentions at least-                        -- one of the class type variables-                        -- The check is disabled for nullary type classes,-                        -- since there is no possible ambiguity (Trac #10020)--             -- Check that any default declarations for associated types are valid-           ; whenIsJust m_dflt_rhs $ \ (rhs, loc) ->-             setSrcSpan loc $-             tcAddFamInstCtxt (text "default type instance") (getName fam_tc) $-             checkValidTyFamEqn fam_tc fam_tvs (mkTyVarTys fam_tvs) rhs }-        where-          fam_tvs = tyConTyVars fam_tc--    check_dm :: UserTypeCtxt -> Id -> PredType -> Type -> DefMethInfo -> TcM ()-    -- Check validity of the /top-level/ generic-default type-    -- E.g for   class C a where-    --             default op :: forall b. (a~b) => blah-    -- we do not want to do an ambiguity check on a type with-    -- a free TyVar 'a' (Trac #11608).  See TcType-    -- Note [TyVars and TcTyVars during type checking] in TcType-    -- Hence the mkDefaultMethodType to close the type.-    check_dm ctxt sel_id vanilla_cls_pred vanilla_tau-             (Just (dm_name, dm_spec@(GenericDM dm_ty)))-      = setSrcSpan (getSrcSpan dm_name) $ do-            -- We have carefully set the SrcSpan on the generic-            -- default-method Name to be that of the generic-            -- default type signature--          -- First, we check that that the method's default type signature-          -- aligns with the non-default type signature.-          -- See Note [Default method type signatures must align]-          let cls_pred = mkClassPred cls $ mkTyVarTys $ classTyVars cls-              -- Note that the second field of this tuple contains the context-              -- of the default type signature, making it apparent that we-              -- ignore method contexts completely when validity-checking-              -- default type signatures. See the end of-              -- Note [Default method type signatures must align]-              -- to learn why this is OK.-              ---              -- See also-              -- Note [Splitting nested sigma types in class type signatures]-              -- for an explanation of why we don't use tcSplitSigmaTy here.-              (_, _, dm_tau) = tcSplitNestedSigmaTys dm_ty--              -- Given this class definition:-              ---              --  class C a b where-              --    op         :: forall p q. (Ord a, D p q)-              --               => a -> b -> p -> (a, b)-              --    default op :: forall r s. E r-              --               => a -> b -> s -> (a, b)-              ---              -- We want to match up two types of the form:-              ---              --   Vanilla type sig: C aa bb => aa -> bb -> p -> (aa, bb)-              --   Default type sig: C a  b  => a  -> b  -> s -> (a,  b)-              ---              -- Notice that the two type signatures can be quantified over-              -- different class type variables! Therefore, it's important that-              -- we include the class predicate parts to match up a with aa and-              -- b with bb.-              vanilla_phi_ty = mkPhiTy [vanilla_cls_pred] vanilla_tau-              dm_phi_ty      = mkPhiTy [cls_pred] dm_tau--          traceTc "check_dm" $ vcat-              [ text "vanilla_phi_ty" <+> ppr vanilla_phi_ty-              , text "dm_phi_ty"      <+> ppr dm_phi_ty ]--          -- Actually checking that the types align is done with a call to-          -- tcMatchTys. We need to get a match in both directions to rule-          -- out degenerate cases like these:-          ---          --  class Foo a where-          --    foo1         :: a -> b-          --    default foo1 :: a -> Int-          ---          --    foo2         :: a -> Int-          --    default foo2 :: a -> b-          unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty]-                                      [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $-               hang (text "The default type signature for"-                     <+> ppr sel_id <> colon)-                 2 (ppr dm_ty)-            $$ (text "does not match its corresponding"-                <+> text "non-default type signature")--          -- Now do an ambiguity check on the default type signature.-          checkValidType ctxt (mkDefaultMethodType cls sel_id dm_spec)-    check_dm _ _ _ _ _ = return ()--checkFamFlag :: Name -> TcM ()--- Check that we don't use families without -XTypeFamilies--- The parser won't even parse them, but I suppose a GHC API--- client might have a go!-checkFamFlag tc_name-  = do { idx_tys <- xoptM LangExt.TypeFamilies-       ; checkTc idx_tys err_msg }-  where-    err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name))-                 2 (text "Enable TypeFamilies to allow indexed type families")--{- Note [Class method constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Haskell 2010 is supposed to reject-  class C a where-    op :: Eq a => a -> a-where the method type constrains only the class variable(s).  (The extension--XConstrainedClassMethods switches off this check.)  But regardless-we should not reject-  class C a where-    op :: (?x::Int) => a -> a-as pointed out in Trac #11793. So the test here rejects the program if-  * -XConstrainedClassMethods is off-  * the tyvars of the constraint are non-empty-  * all the tyvars are class tyvars, none are locally quantified--Note [Abort when superclass cycle is detected]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must avoid doing the ambiguity check for the methods (in-checkValidClass.check_op) when there are already errors accumulated.-This is because one of the errors may be a superclass cycle, and-superclass cycles cause canonicalization to loop. Here is a-representative example:--  class D a => C a where-    meth :: D a => ()-  class C a => D a--This fixes Trac #9415, #9739--Note [Default method type signatures must align]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-GHC enforces the invariant that a class method's default type signature-must "align" with that of the method's non-default type signature, as per-GHC Trac #12918. For instance, if you have:--  class Foo a where-    bar :: forall b. Context => a -> b--Then a default type signature for bar must be alpha equivalent to-(forall b. a -> b). That is, the types must be the same modulo differences in-contexts. So the following would be acceptable default type signatures:--    default bar :: forall b. Context1 => a -> b-    default bar :: forall x. Context2 => a -> x--But the following are NOT acceptable default type signatures:--    default bar :: forall b. b -> a-    default bar :: forall x. x-    default bar :: a -> Int--Note that a is bound by the class declaration for Foo itself, so it is-not allowed to differ in the default type signature.--The default type signature (default bar :: a -> Int) deserves special mention,-since (a -> Int) is a straightforward instantiation of (forall b. a -> b). To-write this, you need to declare the default type signature like so:--    default bar :: forall b. (b ~ Int). a -> b--As noted in #12918, there are several reasons to do this:--1. It would make no sense to have a type that was flat-out incompatible with-   the non-default type signature. For instance, if you had:--     class Foo a where-       bar :: a -> Int-       default bar :: a -> Bool--   Then that would always fail in an instance declaration. So this check-   nips such cases in the bud before they have the chance to produce-   confusing error messages.--2. Internally, GHC uses TypeApplications to instantiate the default method in-   an instance. See Note [Default methods in instances] in TcInstDcls.-   Thus, GHC needs to know exactly what the universally quantified type-   variables are, and when instantiated that way, the default method's type-   must match the expected type.--3. Aesthetically, by only allowing the default type signature to differ in its-   context, we are making it more explicit the ways in which the default type-   signature is less polymorphic than the non-default type signature.--You might be wondering: why are the contexts allowed to be different, but not-the rest of the type signature? That's because default implementations often-rely on assumptions that the more general, non-default type signatures do not.-For instance, in the Enum class declaration:--    class Enum a where-      enum :: [a]-      default enum :: (Generic a, GEnum (Rep a)) => [a]-      enum = map to genum--    class GEnum f where-      genum :: [f a]--The default implementation for enum only works for types that are instances of-Generic, and for which their generic Rep type is an instance of GEnum. But-clearly enum doesn't _have_ to use this implementation, so naturally, the-context for enum is allowed to be different to accomodate this. As a result,-when we validity-check default type signatures, we ignore contexts completely.--Note that when checking whether two type signatures match, we must take care to-split as many foralls as it takes to retrieve the tau types we which to check.-See Note [Splitting nested sigma types in class type signatures].--Note [Splitting nested sigma types in class type signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this type synonym and class definition:--  type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t--  class Each s t a b where-    each         ::                                      Traversal s t a b-    default each :: (Traversable g, s ~ g a, t ~ g b) => Traversal s t a b--It might seem obvious that the tau types in both type signatures for `each`-are the same, but actually getting GHC to conclude this is surprisingly tricky.-That is because in general, the form of a class method's non-default type-signature is:--  forall a. C a => forall d. D d => E a b--And the general form of a default type signature is:--  forall f. F f => E a f -- The variable `a` comes from the class--So it you want to get the tau types in each type signature, you might find it-reasonable to call tcSplitSigmaTy twice on the non-default type signature, and-call it once on the default type signature. For most classes and methods, this-will work, but Each is a bit of an exceptional case. The way `each` is written,-it doesn't quantify any additional type variables besides those of the Each-class itself, so the non-default type signature for `each` is actually this:--  forall s t a b. Each s t a b => Traversal s t a b--Notice that there _appears_ to only be one forall. But there's actually another-forall lurking in the Traversal type synonym, so if you call tcSplitSigmaTy-twice, you'll also go under the forall in Traversal! That is, you'll end up-with:--  (a -> f b) -> s -> f t--A problem arises because you only call tcSplitSigmaTy once on the default type-signature for `each`, which gives you--  Traversal s t a b--Or, equivalently:--  forall f. Applicative f => (a -> f b) -> s -> f t--This is _not_ the same thing as (a -> f b) -> s -> f t! So now tcMatchTy will-say that the tau types for `each` are not equal.--A solution to this problem is to use tcSplitNestedSigmaTys instead of-tcSplitSigmaTy. tcSplitNestedSigmaTys will always split any foralls that it-sees until it can't go any further, so if you called it on the default type-signature for `each`, it would return (a -> f b) -> s -> f t like we desired.--Note [Checking partial record field]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This check checks the partial record field selector, and warns (Trac #7169).--For example:--  data T a = A { m1 :: a, m2 :: a } | B { m1 :: a }--The function 'm2' is partial record field, and will fail when it is applied to-'B'. The warning identifies such partial fields. The check is performed at the-declaration of T, not at the call-sites of m2.--The warning can be suppressed by prefixing the field-name with an underscore.-For example:--  data T a = A { m1 :: a, _m2 :: a } | B { m1 :: a }--************************************************************************-*                                                                      *-                Checking role validity-*                                                                      *-************************************************************************--}--checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcM ()-checkValidRoleAnnots role_annots tc-  | isTypeSynonymTyCon tc = check_no_roles-  | isFamilyTyCon tc      = check_no_roles-  | isAlgTyCon tc         = check_roles-  | otherwise             = return ()-  where-    -- Role annotations are given only on *explicit* variables,-    -- but a tycon stores roles for all variables.-    -- So, we drop the implicit roles (which are all Nominal, anyway).-    name                   = tyConName tc-    roles                  = tyConRoles tc-    (vis_roles, vis_vars)  = unzip $ mapMaybe pick_vis $-                             zip roles (tyConBinders tc)-    role_annot_decl_maybe  = lookupRoleAnnot role_annots name--    pick_vis :: (Role, TyConBinder) -> Maybe (Role, TyVar)-    pick_vis (role, tvb)-      | isVisibleTyConBinder tvb = Just (role, binderVar tvb)-      | otherwise                = Nothing--    check_roles-      = whenIsJust role_annot_decl_maybe $-          \decl@(dL->L loc (RoleAnnotDecl _ _ the_role_annots)) ->-          addRoleAnnotCtxt name $-          setSrcSpan loc $ do-          { role_annots_ok <- xoptM LangExt.RoleAnnotations-          ; checkTc role_annots_ok $ needXRoleAnnotations tc-          ; checkTc (vis_vars `equalLength` the_role_annots)-                    (wrongNumberOfRoles vis_vars decl)-          ; _ <- zipWith3M checkRoleAnnot vis_vars the_role_annots vis_roles-          -- Representational or phantom roles for class parameters-          -- quickly lead to incoherence. So, we require-          -- IncoherentInstances to have them. See #8773, #14292-          ; incoherent_roles_ok <- xoptM LangExt.IncoherentInstances-          ; checkTc (  incoherent_roles_ok-                    || (not $ isClassTyCon tc)-                    || (all (== Nominal) vis_roles))-                    incoherentRoles--          ; lint <- goptM Opt_DoCoreLinting-          ; when lint $ checkValidRoles tc }--    check_no_roles-      = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl--checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM ()-checkRoleAnnot _  (dL->L _ Nothing)   _  = return ()-checkRoleAnnot tv (dL->L _ (Just r1)) r2-  = when (r1 /= r2) $-    addErrTc $ badRoleAnnot (tyVarName tv) r1 r2-checkRoleAnnot _ _ _ = panic "checkRoleAnnot: Impossible Match" -- due to #15884---- This is a double-check on the role inference algorithm. It is only run when--- -dcore-lint is enabled. See Note [Role inference] in TcTyDecls-checkValidRoles :: TyCon -> TcM ()--- If you edit this function, you may need to update the GHC formalism--- See Note [GHC Formalism] in CoreLint-checkValidRoles tc-  | isAlgTyCon tc-    -- tyConDataCons returns an empty list for data families-  = mapM_ check_dc_roles (tyConDataCons tc)-  | Just rhs <- synTyConRhs_maybe tc-  = check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs-  | otherwise-  = return ()-  where-    check_dc_roles datacon-      = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc))-           ; mapM_ (check_ty_roles role_env Representational) $-                    eqSpecPreds eq_spec ++ theta ++ arg_tys }-                    -- See Note [Role-checking data constructor arguments] in TcTyDecls-      where-        (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)-          = dataConFullSig datacon-        univ_roles = zipVarEnv univ_tvs (tyConRoles tc)-              -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs-        ex_roles   = mkVarEnv (map (, Nominal) ex_tvs)-        role_env   = univ_roles `plusVarEnv` ex_roles--    check_ty_roles env role ty-      | Just ty' <- coreView ty -- #14101-      = check_ty_roles env role ty'--    check_ty_roles env role (TyVarTy tv)-      = case lookupVarEnv env tv of-          Just role' -> unless (role' `ltRole` role || role' == role) $-                        report_error $ text "type variable" <+> quotes (ppr tv) <+>-                                       text "cannot have role" <+> ppr role <+>-                                       text "because it was assigned role" <+> ppr role'-          Nothing    -> report_error $ text "type variable" <+> quotes (ppr tv) <+>-                                       text "missing in environment"--    check_ty_roles env Representational (TyConApp tc tys)-      = let roles' = tyConRoles tc in-        zipWithM_ (maybe_check_ty_roles env) roles' tys--    check_ty_roles env Nominal (TyConApp _ tys)-      = mapM_ (check_ty_roles env Nominal) tys--    check_ty_roles _   Phantom ty@(TyConApp {})-      = pprPanic "check_ty_roles" (ppr ty)--    check_ty_roles env role (AppTy ty1 ty2)-      =  check_ty_roles env role    ty1-      >> check_ty_roles env Nominal ty2--    check_ty_roles env role (FunTy ty1 ty2)-      =  check_ty_roles env role ty1-      >> check_ty_roles env role ty2--    check_ty_roles env role (ForAllTy (Bndr tv _) ty)-      =  check_ty_roles env Nominal (tyVarKind tv)-      >> check_ty_roles (extendVarEnv env tv Nominal) role ty--    check_ty_roles _   _    (LitTy {}) = return ()--    check_ty_roles env role (CastTy t _)-      = check_ty_roles env role t--    check_ty_roles _   role (CoercionTy co)-      = unless (role == Phantom) $-        report_error $ text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role--    maybe_check_ty_roles env role ty-      = when (role == Nominal || role == Representational) $-        check_ty_roles env role ty--    report_error doc-      = addErrTc $ vcat [text "Internal error in role inference:",-                         doc,-                         text "Please report this as a GHC bug:  https://www.haskell.org/ghc/reportabug"]--{--************************************************************************-*                                                                      *-                Error messages-*                                                                      *-************************************************************************--}--tcAddTyFamInstCtxt :: TyFamInstDecl GhcRn -> TcM a -> TcM a-tcAddTyFamInstCtxt decl-  = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl)--tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc-tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn =-                            HsIB { hsib_body = eqn }})-  = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance")-                    (unLoc (feqn_tycon eqn))-tcMkDataFamInstCtxt (DataFamInstDecl (XHsImplicitBndrs _))-  = panic "tcMkDataFamInstCtxt"--tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a-tcAddDataFamInstCtxt decl-  = addErrCtxt (tcMkDataFamInstCtxt decl)--tcMkFamInstCtxt :: SDoc -> Name -> SDoc-tcMkFamInstCtxt flavour tycon-  = hsep [ text "In the" <+> flavour <+> text "declaration for"-         , quotes (ppr tycon) ]--tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a-tcAddFamInstCtxt flavour tycon thing_inside-  = addErrCtxt (tcMkFamInstCtxt flavour tycon) thing_inside--tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a-tcAddClosedTypeFamilyDeclCtxt tc-  = addErrCtxt ctxt-  where-    ctxt = text "In the equations for closed type family" <+>-           quotes (ppr tc)--resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc-resultTypeMisMatch field_name con1 con2-  = vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,-                text "have a common field" <+> quotes (ppr field_name) <> comma],-          nest 2 $ text "but have different result types"]--fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc-fieldTypeMisMatch field_name con1 con2-  = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,-         text "give different types for field", quotes (ppr field_name)]--dataConCtxtName :: [Located Name] -> SDoc-dataConCtxtName [con]-   = text "In the definition of data constructor" <+> quotes (ppr con)-dataConCtxtName con-   = text "In the definition of data constructors" <+> interpp'SP con--dataConCtxt :: Outputable a => a -> SDoc-dataConCtxt con = text "In the definition of data constructor" <+> quotes (ppr con)--classOpCtxt :: Var -> Type -> SDoc-classOpCtxt sel_id tau = sep [text "When checking the class method:",-                              nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)]--classArityErr :: Int -> Class -> SDoc-classArityErr n cls-    | n == 0 = mkErr "No" "no-parameter"-    | otherwise = mkErr "Too many" "multi-parameter"-  where-    mkErr howMany allowWhat =-        vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls),-              parens (text ("Enable MultiParamTypeClasses to allow "-                                    ++ allowWhat ++ " classes"))]--classFunDepsErr :: Class -> SDoc-classFunDepsErr cls-  = vcat [text "Fundeps in class" <+> quotes (ppr cls),-          parens (text "Enable FunctionalDependencies to allow fundeps")]--badMethPred :: Id -> TcPredType -> SDoc-badMethPred sel_id pred-  = vcat [ hang (text "Constraint" <+> quotes (ppr pred)-                 <+> text "in the type of" <+> quotes (ppr sel_id))-              2 (text "constrains only the class type variables")-         , text "Enable ConstrainedClassMethods to allow it" ]--noClassTyVarErr :: Class -> TyCon -> SDoc-noClassTyVarErr clas fam_tc-  = sep [ text "The associated type" <+> quotes (ppr fam_tc)-        , text "mentions none of the type or kind variables of the class" <+>-                quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))]--badDataConTyCon :: DataCon -> Type -> Type -> SDoc-badDataConTyCon data_con res_ty_tmpl actual_res_ty-  | ASSERT( all isTyVar actual_ex_tvs )-    tcIsForAllTy actual_res_ty-  = nested_foralls_contexts_suggestion-  | isJust (tcSplitPredFunTy_maybe actual_res_ty)-  = nested_foralls_contexts_suggestion-  | otherwise-  = hang (text "Data constructor" <+> quotes (ppr data_con) <+>-                text "returns type" <+> quotes (ppr actual_res_ty))-       2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl))-  where-    -- This suggestion is useful for suggesting how to correct code like what-    -- was reported in Trac #12087:-    ---    --   data F a where-    --     MkF :: Ord a => Eq a => a -> F a-    ---    -- Although nested foralls or contexts are allowed in function type-    -- signatures, it is much more difficult to engineer GADT constructor type-    -- signatures to allow something similar, so we error in the latter case.-    -- Nevertheless, we can at least suggest how a user might reshuffle their-    -- exotic GADT constructor type signature so that GHC will accept.-    nested_foralls_contexts_suggestion =-      text "GADT constructor type signature cannot contain nested"-      <+> quotes forAllLit <> text "s or contexts"-      $+$ hang (text "Suggestion: instead use this type signature:")-             2 (ppr (dataConName data_con) <+> dcolon <+> ppr suggested_ty)--    -- To construct a type that GHC would accept (suggested_ty), we:-    ---    -- 1) Find the existentially quantified type variables and the class-    --    predicates from the datacon. (NB: We don't need the universally-    --    quantified type variables, since rejigConRes won't substitute them in-    --    the result type if it fails, as in this scenario.)-    -- 2) Split apart the return type (which is headed by a forall or a-    --    context) using tcSplitNestedSigmaTys, collecting the type variables-    --    and class predicates we find, as well as the rho type lurking-    --    underneath the nested foralls and contexts.-    -- 3) Smash together the type variables and class predicates from 1) and-    --    2), and prepend them to the rho type from 2).-    actual_ex_tvs = dataConExTyCoVars data_con-    actual_theta  = dataConTheta data_con-    (actual_res_tvs, actual_res_theta, actual_res_rho)-      = tcSplitNestedSigmaTys actual_res_ty-    suggested_ty = mkSpecForAllTys (actual_ex_tvs ++ actual_res_tvs) $-                   mkFunTys (actual_theta ++ actual_res_theta)-                   actual_res_rho--badGadtDecl :: Name -> SDoc-badGadtDecl tc_name-  = vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name)-         , nest 2 (parens $ text "Enable the GADTs extension to allow this") ]--badExistential :: DataCon -> SDoc-badExistential con-  = hang (text "Data constructor" <+> quotes (ppr con) <+>-                text "has existential type variables, a context, or a specialised result type")-       2 (vcat [ ppr con <+> dcolon <+> ppr (dataConUserType con)-               , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ])--badStupidTheta :: Name -> SDoc-badStupidTheta tc_name-  = text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name)--newtypeConError :: Name -> Int -> SDoc-newtypeConError tycon n-  = sep [text "A newtype must have exactly one constructor,",-         nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ]--newtypeStrictError :: DataCon -> SDoc-newtypeStrictError con-  = sep [text "A newtype constructor cannot have a strictness annotation,",-         nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"]--newtypeFieldErr :: DataCon -> Int -> SDoc-newtypeFieldErr con_name n_flds-  = sep [text "The constructor of a newtype must have exactly one field",-         nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds]--badSigTyDecl :: Name -> SDoc-badSigTyDecl tc_name-  = vcat [ text "Illegal kind signature" <+>-           quotes (ppr tc_name)-         , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ]--emptyConDeclsErr :: Name -> SDoc-emptyConDeclsErr tycon-  = sep [quotes (ppr tycon) <+> text "has no constructors",-         nest 2 $ text "(EmptyDataDecls permits this)"]--wrongKindOfFamily :: TyCon -> SDoc-wrongKindOfFamily family-  = text "Wrong category of family instance; declaration was for a"-    <+> kindOfFamily-  where-    kindOfFamily | isTypeFamilyTyCon family = text "type family"-                 | isDataFamilyTyCon family = text "data family"-                 | otherwise = pprPanic "wrongKindOfFamily" (ppr family)---- | Produce an error for oversaturated type family equations with too many--- required arguments.--- See Note [Oversaturated type family equations] in TcValidity.-wrongNumberOfParmsErr :: Arity -> SDoc-wrongNumberOfParmsErr max_args-  = text "Number of parameters must match family declaration; expected"-    <+> ppr max_args--defaultAssocKindErr :: TyCon -> SDoc-defaultAssocKindErr fam_tc-  = text "Kind mis-match on LHS of default declaration for"-    <+> quotes (ppr fam_tc)--badRoleAnnot :: Name -> Role -> Role -> SDoc-badRoleAnnot var annot inferred-  = hang (text "Role mismatch on variable" <+> ppr var <> colon)-       2 (sep [ text "Annotation says", ppr annot-              , text "but role", ppr inferred-              , text "is required" ])--wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc-wrongNumberOfRoles tyvars d@(dL->L _ (RoleAnnotDecl _ _ annots))-  = hang (text "Wrong number of roles listed in role annotation;" $$-          text "Expected" <+> (ppr $ length tyvars) <> comma <+>-          text "got" <+> (ppr $ length annots) <> colon)-       2 (ppr d)-wrongNumberOfRoles _ (dL->L _ (XRoleAnnotDecl _)) = panic "wrongNumberOfRoles"-wrongNumberOfRoles _ _ = panic "wrongNumberOfRoles: Impossible Match"-                         -- due to #15884---illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM ()-illegalRoleAnnotDecl (dL->L loc (RoleAnnotDecl _ tycon _))-  = setErrCtxt [] $-    setSrcSpan loc $-    addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$-              text "they are allowed only for datatypes and classes.")-illegalRoleAnnotDecl (dL->L _ (XRoleAnnotDecl _)) = panic "illegalRoleAnnotDecl"+        kcConDecls, tcConDecls, dataDeclChecks, checkValidTyCon,+        tcFamTyPats, tcTyFamInstEqn,+        tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,+        unravelFamInstPats, addConsistencyConstraints,+        wrongKindOfFamily+    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Hs+import HscTypes+import BuildTyCl+import TcRnMonad+import TcEnv+import TcValidity+import TcHsSyn+import TcTyDecls+import TcClassDcl+import {-# SOURCE #-} TcInstDcls( tcInstDecls1 )+import TcDeriv (DerivInfo(..))+import TcUnify ( unifyKind )+import TcHsType+import ClsInst( AssocInstInfo(..) )+import TcMType+import TysWiredIn ( unitTy, makeRecoveryTyCon )+import TcType+import RnEnv( lookupConstructorFields )+import FamInst+import FamInstEnv+import Coercion+import TcOrigin+import Type+import TyCoRep   -- for checkValidRoles+import TyCoPpr( pprTyVars, pprWithExplicitKindsWhen )+import Class+import CoAxiom+import TyCon+import DataCon+import Id+import Var+import VarEnv+import VarSet+import Module+import Name+import NameSet+import NameEnv+import Outputable+import Maybes+import Unify+import Util+import SrcLoc+import ListSetOps+import DynFlags+import Unique+import ConLike( ConLike(..) )+import BasicTypes+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Data.Foldable+import Data.Function ( on )+import Data.List+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty ( NonEmpty(..) )+import qualified Data.Set as Set+++{-+************************************************************************+*                                                                      *+\subsection{Type checking for type and class declarations}+*                                                                      *+************************************************************************++Note [Grouping of type and class declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly+connected component of mutually dependent types and classes. We kind check and+type check each group separately to enhance kind polymorphism. Take the+following example:++  type Id a = a+  data X = X (Id Int)++If we were to kind check the two declarations together, we would give Id the+kind * -> *, since we apply it to an Int in the definition of X. But we can do+better than that, since Id really is kind polymorphic, and should get kind+forall (k::*). k -> k. Since it does not depend on anything else, it can be+kind-checked by itself, hence getting the most general kind. We then kind check+X, which works fine because we then know the polymorphic kind of Id, and simply+instantiate k to *.++Note [Check role annotations in a second pass]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Role inference potentially depends on the types of all of the datacons declared+in a mutually recursive group. The validity of a role annotation, in turn,+depends on the result of role inference. Because the types of datacons might+be ill-formed (see #7175 and Note [Checking GADT return types]) we must check+*all* the tycons in a group for validity before checking *any* of the roles.+Thus, we take two passes over the resulting tycons, first checking for general+validity and then checking for valid role annotations.+-}++tcTyAndClassDecls :: [TyClGroup GhcRn]      -- Mutually-recursive groups in+                                            -- dependency order+                  -> TcM ( TcGblEnv         -- Input env extended by types and+                                            -- classes+                                            -- and their implicit Ids,DataCons+                         , [InstInfo GhcRn] -- Source-code instance decls info+                         , [DerivInfo]      -- Deriving info+                         )+-- Fails if there are any errors+tcTyAndClassDecls tyclds_s+  -- The code recovers internally, but if anything gave rise to+  -- an error we'd better stop now, to avoid a cascade+  -- Type check each group in dependency order folding the global env+  = checkNoErrs $ fold_env [] [] tyclds_s+  where+    fold_env :: [InstInfo GhcRn]+             -> [DerivInfo]+             -> [TyClGroup GhcRn]+             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])+    fold_env inst_info deriv_info []+      = do { gbl_env <- getGblEnv+           ; return (gbl_env, inst_info, deriv_info) }+    fold_env inst_info deriv_info (tyclds:tyclds_s)+      = do { (tcg_env, inst_info', deriv_info') <- tcTyClGroup tyclds+           ; setGblEnv tcg_env $+               -- remaining groups are typechecked in the extended global env.+             fold_env (inst_info' ++ inst_info)+                      (deriv_info' ++ deriv_info)+                      tyclds_s }++tcTyClGroup :: TyClGroup GhcRn+            -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])+-- Typecheck one strongly-connected component of type, class, and instance decls+-- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls+tcTyClGroup (TyClGroup { group_tyclds = tyclds+                       , group_roles  = roles+                       , group_kisigs = kisigs+                       , group_instds = instds })+  = do { let role_annots = mkRoleAnnotEnv roles++           -- Step 1: Typecheck the standalone kind signatures and type/class declarations+       ; traceTc "---- tcTyClGroup ---- {" empty+       ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds))+       ; (tyclss, data_deriv_info) <-+           tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution]+           do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs+              ; tcTyClDecls tyclds kisig_env role_annots }++           -- Step 1.5: Make sure we don't have any type synonym cycles+       ; traceTc "Starting synonym cycle check" (ppr tyclss)+       ; this_uid <- fmap thisPackage getDynFlags+       ; checkSynCycles this_uid tyclss tyclds+       ; traceTc "Done synonym cycle check" (ppr tyclss)++           -- Step 2: Perform the validity check on those types/classes+           -- We can do this now because we are done with the recursive knot+           -- Do it before Step 3 (adding implicit things) because the latter+           -- expects well-formed TyCons+       ; traceTc "Starting validity check" (ppr tyclss)+       ; tyclss <- concatMapM checkValidTyCl tyclss+       ; traceTc "Done validity check" (ppr tyclss)+       ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss+           -- See Note [Check role annotations in a second pass]++       ; traceTc "---- end tcTyClGroup ---- }" empty++           -- Step 3: Add the implicit things;+           -- we want them in the environment because+           -- they may be mentioned in interface files+       ; gbl_env <- addTyConsToGblEnv tyclss++           -- Step 4: check instance declarations+       ; (gbl_env', inst_info, datafam_deriv_info) <-+         setGblEnv gbl_env $+         tcInstDecls1 instds++       ; let deriv_info = datafam_deriv_info ++ data_deriv_info+       ; return (gbl_env', inst_info, deriv_info) }+++tcTyClGroup (XTyClGroup nec) = noExtCon nec++-- Gives the kind for every TyCon that has a standalone kind signature+type KindSigEnv = NameEnv Kind++tcTyClDecls+  :: [LTyClDecl GhcRn]+  -> KindSigEnv+  -> RoleAnnotEnv+  -> TcM ([TyCon], [DerivInfo])+tcTyClDecls tyclds kisig_env role_annots+  = do {    -- Step 1: kind-check this group and returns the final+            -- (possibly-polymorphic) kind of each TyCon and Class+            -- See Note [Kind checking for type and class decls]+         tc_tycons <- kcTyClGroup kisig_env tyclds+       ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons))++            -- Step 2: type-check all groups together, returning+            -- the final TyCons and Classes+            --+            -- NB: We have to be careful here to NOT eagerly unfold+            -- type synonyms, as we have not tested for type synonym+            -- loops yet and could fall into a black hole.+       ; fixM $ \ ~(rec_tyclss, _) -> do+           { tcg_env <- getGblEnv+           ; let roles = inferRoles (tcg_src tcg_env) role_annots rec_tyclss++                 -- Populate environment with knot-tied ATyCon for TyCons+                 -- NB: if the decls mention any ill-staged data cons+                 -- (see Note [Recursion and promoting data constructors])+                 -- we will have failed already in kcTyClGroup, so no worries here+           ; (tycons, data_deriv_infos) <-+             tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $++                 -- Also extend the local type envt with bindings giving+                 -- a TcTyCon for each each knot-tied TyCon or Class+                 -- See Note [Type checking recursive type and class declarations]+                 -- and Note [Type environment evolution]+             tcExtendKindEnvWithTyCons tc_tycons $++                 -- Kind and type check declarations for this group+               mapAndUnzipM (tcTyClDecl roles) tyclds+           ; return (tycons, concat data_deriv_infos)+           } }+  where+    ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma+                                  , ppr (tyConBinders tc) <> comma+                                  , ppr (tyConResKind tc)+                                  , ppr (isTcTyCon tc) ])++zipRecTyClss :: [TcTyCon]+             -> [TyCon]           -- Knot-tied+             -> [(Name,TyThing)]+-- Build a name-TyThing mapping for the TyCons bound by decls+-- being careful not to look at the knot-tied [TyThing]+-- The TyThings in the result list must have a visible ATyCon,+-- because typechecking types (in, say, tcTyClDecl) looks at+-- this outer constructor+zipRecTyClss tc_tycons rec_tycons+  = [ (name, ATyCon (get name)) | tc_tycon <- tc_tycons, let name = getName tc_tycon ]+  where+    rec_tc_env :: NameEnv TyCon+    rec_tc_env = foldr add_tc emptyNameEnv rec_tycons++    add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon+    add_tc tc env = foldr add_one_tc env (tc : tyConATs tc)++    add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon+    add_one_tc tc env = extendNameEnv env (tyConName tc) tc++    get name = case lookupNameEnv rec_tc_env name of+                 Just tc -> tc+                 other   -> pprPanic "zipRecTyClss" (ppr name <+> ppr other)++{-+************************************************************************+*                                                                      *+                Kind checking+*                                                                      *+************************************************************************++Note [Kind checking for type and class decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Kind checking is done thus:++   1. Make up a kind variable for each parameter of the declarations,+      and extend the kind environment (which is in the TcLclEnv)++   2. Kind check the declarations++We need to kind check all types in the mutually recursive group+before we know the kind of the type variables.  For example:++  class C a where+     op :: D b => a -> b -> b++  class D c where+     bop :: (Monad c) => ...++Here, the kind of the locally-polymorphic type variable "b"+depends on *all the uses of class D*.  For example, the use of+Monad c in bop's type signature means that D must have kind Type->Type.++Note: we don't treat type synonyms specially (we used to, in the past);+in particular, even if we have a type synonym cycle, we still kind check+it normally, and test for cycles later (checkSynCycles).  The reason+we can get away with this is because we have more systematic TYPE r+inference, which means that we can do unification between kinds that+aren't lifted (this historically was not true.)++The downside of not directly reading off the kinds of the RHS of+type synonyms in topological order is that we don't transparently+support making synonyms of types with higher-rank kinds.  But+you can always specify a CUSK directly to make this work out.+See tc269 for an example.++Note [Skip decls with CUSKs in kcLTyClDecl]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++    data T (a :: *) = MkT (S a)   -- Has CUSK+    data S a = MkS (T Int) (S a)  -- No CUSK++Via inferInitialKinds we get+  T :: * -> *+  S :: kappa -> *++Then we call kcTyClDecl on each decl in the group, to constrain the+kind unification variables.  BUT we /skip/ the RHS of any decl with+a CUSK.  Here we skip the RHS of T, so we eventually get+  S :: forall k. k -> *++This gets us more polymorphism than we would otherwise get, similar+(but implemented strangely differently from) the treatment of type+signatures in value declarations.++However, we only want to do so when we have PolyKinds.+When we have NoPolyKinds, we don't skip those decls, because we have defaulting+(#16609). Skipping won't bring us more polymorphism when we have defaulting.+Consider++  data T1 a = MkT1 T2        -- No CUSK+  data T2 = MkT2 (T1 Maybe)  -- Has CUSK++If we skip the rhs of T2 during kind-checking, the kind of a remains unsolved.+With PolyKinds, we do generalization to get T1 :: forall a. a -> *. And the+program type-checks.+But with NoPolyKinds, we do defaulting to get T1 :: * -> *. Defaulting happens+in quantifyTyVars, which is called from generaliseTcTyCon. Then type-checking+(T1 Maybe) will throw a type error.++Summary: with PolyKinds, we must skip; with NoPolyKinds, we must /not/ skip.++Open type families+~~~~~~~~~~~~~~~~~~+This treatment of type synonyms only applies to Haskell 98-style synonyms.+General type functions can be recursive, and hence, appear in `alg_decls'.++The kind of an open type family is solely determinded by its kind signature;+hence, only kind signatures participate in the construction of the initial+kind environment (as constructed by `inferInitialKind'). In fact, we ignore+instances of families altogether in the following. However, we need to include+the kinds of *associated* families into the construction of the initial kind+environment. (This is handled by `allDecls').++See also Note [Kind checking recursive type and class declarations]++Note [How TcTyCons work]+~~~~~~~~~~~~~~~~~~~~~~~~+TcTyCons are used for two distinct purposes++1.  When recovering from a type error in a type declaration,+    we want to put the erroneous TyCon in the environment in a+    way that won't lead to more errors.  We use a TcTyCon for this;+    see makeRecoveryTyCon.++2.  When checking a type/class declaration (in module TcTyClsDecls), we come+    upon knowledge of the eventual tycon in bits and pieces.++      S1) First, we use inferInitialKinds to look over the user-provided+          kind signature of a tycon (including, for example, the number+          of parameters written to the tycon) to get an initial shape of+          the tycon's kind.  We record that shape in a TcTyCon.++          For CUSK tycons, the TcTyCon has the final, generalised kind.+          For non-CUSK tycons, the TcTyCon has as its tyConBinders only+          the explicit arguments given -- no kind variables, etc.++      S2) Then, using these initial kinds, we kind-check the body of the+          tycon (class methods, data constructors, etc.), filling in the+          metavariables in the tycon's initial kind.++      S3) We then generalize to get the (non-CUSK) tycon's final, fixed+          kind. Finally, once this has happened for all tycons in a+          mutually recursive group, we can desugar the lot.++    For convenience, we store partially-known tycons in TcTyCons, which+    might store meta-variables. These TcTyCons are stored in the local+    environment in TcTyClsDecls, until the real full TyCons can be created+    during desugaring. A desugared program should never have a TcTyCon.++3.  In a TcTyCon, everything is zonked after the kind-checking pass (S2).++4.  tyConScopedTyVars.  A challenging piece in all of this is that we+    end up taking three separate passes over every declaration:+      - one in inferInitialKind (this pass look only at the head, not the body)+      - one in kcTyClDecls (to kind-check the body)+      - a final one in tcTyClDecls (to desugar)++    In the latter two passes, we need to connect the user-written type+    variables in an LHsQTyVars with the variables in the tycon's+    inferred kind. Because the tycon might not have a CUSK, this+    matching up is, in general, quite hard to do.  (Look through the+    git history between Dec 2015 and Apr 2016 for+    TcHsType.splitTelescopeTvs!)++    Instead of trying, we just store the list of type variables to+    bring into scope, in the tyConScopedTyVars field of the TcTyCon.+    These tyvars are brought into scope in TcHsType.bindTyClTyVars.++    In a TcTyCon, why is tyConScopedTyVars :: [(Name,TcTyVar)] rather+    than just [TcTyVar]?  Consider these mutually-recursive decls+       data T (a :: k1) b = MkT (S a b)+       data S (c :: k2) d = MkS (T c d)+    We start with k1 bound to kappa1, and k2 to kappa2; so initially+    in the (Name,TcTyVar) pairs the Name is that of the TcTyVar. But+    then kappa1 and kappa2 get unified; so after the zonking in+    'generalise' in 'kcTyClGroup' the Name and TcTyVar may differ.++See also Note [Type checking recursive type and class declarations].++Note [Type environment evolution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As we typecheck a group of declarations the type environment evolves.+Consider for example:+  data B (a :: Type) = MkB (Proxy 'MkB)++We do the following steps:++  1. Start of tcTyClDecls: use mkPromotionErrorEnv to initialise the+     type env with promotion errors+            B   :-> TyConPE+            MkB :-> DataConPE++  2. kcTyCLGroup+      - Do inferInitialKinds, which will signal a promotion+        error if B is used in any of the kinds needed to initialise+        B's kind (e.g. (a :: Type)) here++      - Extend the type env with these initial kinds (monomorphic for+        decls that lack a CUSK)+            B :-> TcTyCon <initial kind>+        (thereby overriding the B :-> TyConPE binding)+        and do kcLTyClDecl on each decl to get equality constraints on+        all those inital kinds++      - Generalise the inital kind, making a poly-kinded TcTyCon++  3. Back in tcTyDecls, extend the envt with bindings of the poly-kinded+     TcTyCons, again overriding the promotion-error bindings.++     But note that the data constructor promotion errors are still in place+     so that (in our example) a use of MkB will sitll be signalled as+     an error.++  4. Typecheck the decls.++  5. In tcTyClGroup, extend the envt with bindings for TyCon and DataCons+++Note [Missed opportunity to retain higher-rank kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In 'kcTyClGroup', there is a missed opportunity to make kind+inference work in a few more cases.  The idea is analogous+to Note [Single function non-recursive binding special-case]:++     * If we have an SCC with a single decl, which is non-recursive,+       instead of creating a unification variable representing the+       kind of the decl and unifying it with the rhs, we can just+       read the type directly of the rhs.++     * Furthermore, we can update our SCC analysis to ignore+       dependencies on declarations which have CUSKs: we don't+       have to kind-check these all at once, since we can use+       the CUSK to initialize the kind environment.++Unfortunately this requires reworking a bit of the code in+'kcLTyClDecl' so I've decided to punt unless someone shouts about it.++Note [Don't process associated types in getInitialKind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Previously, we processed associated types in the thing_inside in getInitialKind,+but this was wrong -- we want to do ATs sepearately.+The consequence for not doing it this way is #15142:++  class ListTuple (tuple :: Type) (as :: [(k, Type)]) where+    type ListToTuple as :: Type++We assign k a kind kappa[1]. When checking the tuple (k, Type), we try to unify+kappa ~ Type, but this gets deferred because we bumped the TcLevel as we bring+`tuple` into scope. Thus, when we check ListToTuple, kappa[1] still hasn't+unified with Type. And then, when we generalize the kind of ListToTuple (which+indeed has a CUSK, according to the rules), we skolemize the free metavariable+kappa. Note that we wouldn't skolemize kappa when generalizing the kind of ListTuple,+because the solveEqualities in kcInferDeclHeader is at TcLevel 1 and so kappa[1]+will unify with Type.++Bottom line: as associated types should have no effect on a CUSK enclosing class,+we move processing them to a separate action, run after the outer kind has+been generalized.++-}++kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM [TcTyCon]++-- Kind check this group, kind generalize, and return the resulting local env+-- This binds the TyCons and Classes of the group, but not the DataCons+-- See Note [Kind checking for type and class decls]+-- and Note [Inferring kinds for type declarations]+kcTyClGroup kisig_env decls+  = do  { mod <- getModule+        ; traceTc "---- kcTyClGroup ---- {"+                  (text "module" <+> ppr mod $$ vcat (map ppr decls))++          -- Kind checking;+          --    1. Bind kind variables for decls+          --    2. Kind-check decls+          --    3. Generalise the inferred kinds+          -- See Note [Kind checking for type and class decls]++        ; cusks_enabled <- xoptM LangExt.CUSKs+        ; let (kindless_decls, kinded_decls) = partitionWith get_kind decls++              get_kind d+                | Just ki <- lookupNameEnv kisig_env (tcdName (unLoc d))+                = Right (d, SAKS ki)++                | cusks_enabled && hsDeclHasCusk (unLoc d)+                = Right (d, CUSK)++                | otherwise = Left d++        ; checked_tcs <- checkInitialKinds kinded_decls+        ; inferred_tcs+            <- tcExtendKindEnvWithTyCons checked_tcs $+               pushTcLevelM_   $  -- We are going to kind-generalise, so+                                  -- unification variables in here must+                                  -- be one level in+               solveEqualities $+               do {  -- Step 1: Bind kind variables for all decls+                    mono_tcs <- inferInitialKinds kindless_decls++                  ; traceTc "kcTyClGroup: initial kinds" $+                    ppr_tc_kinds mono_tcs++                    -- Step 2: Set extended envt, kind-check the decls+                    -- NB: the environment extension overrides the tycon+                    --     promotion-errors bindings+                    --     See Note [Type environment evolution]+                  ; poly_kinds  <- xoptM LangExt.PolyKinds+                  ; tcExtendKindEnvWithTyCons mono_tcs $+                    mapM_ kcLTyClDecl (if poly_kinds then kindless_decls else decls)+                    -- See Note [Skip decls with CUSKs in kcLTyClDecl]++                  ; return mono_tcs }++        -- Step 3: generalisation+        -- Finally, go through each tycon and give it its final kind,+        -- with all the required, specified, and inferred variables+        -- in order.+        ; generalized_tcs <- mapAndReportM generaliseTcTyCon inferred_tcs++        ; let poly_tcs = checked_tcs ++ generalized_tcs+        ; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs)+        ; return poly_tcs }++  where+    ppr_tc_kinds tcs = vcat (map pp_tc tcs)+    pp_tc tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc)++generaliseTcTyCon :: TcTyCon -> TcM TcTyCon+generaliseTcTyCon tc+  -- See Note [Required, Specified, and Inferred for types]+  = setSrcSpan (getSrcSpan tc) $+    addTyConCtxt tc $+    do { let tc_name      = tyConName tc+             tc_res_kind  = tyConResKind tc+             spec_req_prs = tcTyConScopedTyVars tc++             (spec_req_names, spec_req_tvs) = unzip spec_req_prs+             -- NB: spec_req_tvs includes both Specified and Required+             -- Running example in Note [Inferring kinds for type declarations]+             --    spec_req_prs = [ ("k1",kk1), ("a", (aa::kk1))+             --                   , ("k2",kk2), ("x", (xx::kk2))]+             -- where "k1" dnotes the Name k1, and kk1, aa, etc are MetaTyVars,+             -- specifically TyVarTvs++       -- Step 0: zonk and skolemise the Specified and Required binders+       -- It's essential that they are skolems, not MetaTyVars,+       -- for Step 3 to work right+       ; spec_req_tvs <- mapM zonkAndSkolemise spec_req_tvs+             -- Running example, where kk1 := kk2, so we get+             --   [kk2,kk2]++       -- Step 1: Check for duplicates+       -- E.g. data SameKind (a::k) (b::k)+       --      data T (a::k1) (b::k2) = MkT (SameKind a b)+       -- Here k1 and k2 start as TyVarTvs, and get unified with each other+       -- If this happens, things get very confused later, so fail fast+       ; checkDuplicateTyConBinders spec_req_names spec_req_tvs++       -- Step 2a: find all the Inferred variables we want to quantify over+       -- NB: candidateQTyVarsOfKinds zonks as it goes+       ; dvs1 <- candidateQTyVarsOfKinds $+                (tc_res_kind : map tyVarKind spec_req_tvs)+       ; let dvs2 = dvs1 `delCandidates` spec_req_tvs++       -- Step 2b: quantify, mainly meaning skolemise the free variables+       -- Returned 'inferred' are scope-sorted and skolemised+       ; inferred <- quantifyTyVars dvs2++       -- Step 3a: rename all the Specified and Required tyvars back to+       -- TyVars with their oroginal user-specified name.  Example+       --     class C a_r23 where ....+       -- By this point we have scoped_prs = [(a_r23, a_r89[TyVarTv])]+       -- We return with the TyVar a_r23[TyVar],+       --    and ze mapping a_r89 :-> a_r23[TyVar]+       ; traceTc "generaliseTcTyCon: before zonkRec"+           (vcat [ text "spec_req_tvs =" <+> pprTyVars spec_req_tvs+                 , text "inferred =" <+> pprTyVars inferred ])+       ; (ze, final_spec_req_tvs) <- zonkRecTyVarBndrs spec_req_names spec_req_tvs+           -- So ze maps from the tyvars that have ended up++       -- Step 3b: Apply that mapping to the other variables+       -- (remember they all started as TyVarTvs).+       -- They have been skolemised by quantifyTyVars.+       ; (ze, inferred) <- zonkTyBndrsX ze inferred+       ; tc_res_kind    <- zonkTcTypeToTypeX ze tc_res_kind++       ; traceTc "generaliseTcTyCon: post zonk" $+         vcat [ text "tycon =" <+> ppr tc+              , text "inferred =" <+> pprTyVars inferred+              , text "ze =" <+> ppr ze+              , text "spec_req_prs =" <+> ppr spec_req_prs+              , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs+              , text "final_spec_req_tvs =" <+> pprTyVars final_spec_req_tvs ]++       -- Step 4: Find the Specified and Inferred variables+       -- NB: spec_req_tvs = spec_tvs ++ req_tvs+       --     And req_tvs is 1-1 with tyConTyVars+       --     See Note [Scoped tyvars in a TcTyCon] in TyCon+       ; let n_spec        = length final_spec_req_tvs - tyConArity tc+             (spec_tvs, req_tvs) = splitAt n_spec final_spec_req_tvs+             specified     = scopedSort spec_tvs+                             -- NB: maintain the L-R order of scoped_tvs++       -- Step 5: Make the TyConBinders.+             to_user tv     = lookupTyVarOcc ze tv `orElse` tv+             dep_fv_set     = mapVarSet to_user (candidateKindVars dvs1)+             inferred_tcbs  = mkNamedTyConBinders Inferred inferred+             specified_tcbs = mkNamedTyConBinders Specified specified+             required_tcbs  = map (mkRequiredTyConBinder dep_fv_set) req_tvs++       -- Step 6: Assemble the final list.+             final_tcbs = concat [ inferred_tcbs+                                 , specified_tcbs+                                 , required_tcbs ]++       -- Step 7: Make the result TcTyCon+             tycon = mkTcTyCon tc_name final_tcbs tc_res_kind+                            (mkTyVarNamePairs final_spec_req_tvs)+                            True {- it's generalised now -}+                            (tyConFlavour tc)++       ; traceTc "generaliseTcTyCon done" $+         vcat [ text "tycon =" <+> ppr tc+              , text "tc_res_kind =" <+> ppr tc_res_kind+              , text "dep_fv_set =" <+> ppr dep_fv_set+              , text "final_spec_req_tvs =" <+> pprTyVars final_spec_req_tvs+              , text "inferred =" <+> pprTyVars inferred+              , text "specified =" <+> pprTyVars specified+              , text "required_tcbs =" <+> ppr required_tcbs+              , text "final_tcbs =" <+> ppr final_tcbs ]++       -- Step 8: Check for validity.+       -- We do this here because we're about to put the tycon into the+       -- the environment, and we don't want anything malformed there+       ; checkTyConTelescope tycon++       ; return tycon }++checkDuplicateTyConBinders :: [Name] -> [TcTyVar] -> TcM ()+checkDuplicateTyConBinders spec_req_names spec_req_tvs+  | null dups = return ()+  | otherwise = mapM_ report_dup dups >> failM+  where+    dups :: [(Name,Name)]+    dups = findDupTyVarTvs $ spec_req_names `zip` spec_req_tvs++    report_dup (n1, n2)+      = setSrcSpan (getSrcSpan n2) $+        addErrTc (text "Couldn't match" <+> quotes (ppr n1)+                        <+> text "with" <+> quotes (ppr n2))++{- Note [Required, Specified, and Inferred for types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Each forall'd type variable in a type or kind is one of++  * Required: an argument must be provided at every call site++  * Specified: the argument can be inferred at call sites, but+    may be instantiated with visible type/kind application++  * Inferred: the must be inferred at call sites; it+    is unavailable for use with visible type/kind application.++Why have Inferred at all? Because we just can't make user-facing+promises about the ordering of some variables. These might swizzle+around even between minor released. By forbidding visible type+application, we ensure users aren't caught unawares.++Go read Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.++The question for this Note is this:+   given a TyClDecl, how are its quantified type variables classified?+Much of the debate is memorialized in #15743.++Here is our design choice. When inferring the ordering of variables+for a TyCl declaration (that is, for those variables that he user+has not specified the order with an explicit `forall`), we use the+following order:++ 1. Inferred variables+ 2. Specified variables; in the left-to-right order in which+    the user wrote them, modified by scopedSort (see below)+    to put them in depdendency order.+ 3. Required variables before a top-level ::+ 4. All variables after a top-level ::++If this ordering does not make a valid telescope, we reject the definition.++Example:+  data SameKind :: k -> k -> *+  data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d)++For Bad:+  - a, c, d, x are Required; they are explicitly listed by the user+    as the positional arguments of Bad+  - b is Specified; it appears explicitly in a kind signature+  - k, the kind of a, is Inferred; it is not mentioned explicitly at all++Putting variables in the order Inferred, Specified, Required+gives us this telescope:+  Inferred:  k+  Specified: b : Proxy a+  Required : (a : k) (c : Proxy b) (d : Proxy a) (x : SameKind b d)++But this order is ill-scoped, because b's kind mentions a, which occurs+after b in the telescope. So we reject Bad.++Associated types+~~~~~~~~~~~~~~~~+For associated types everything above is determined by the+associated-type declaration alone, ignoring the class header.+Here is an example (#15592)+  class C (a :: k) b where+    type F (x :: b a)++In the kind of C, 'k' is Specified.  But what about F?+In the kind of F,++ * Should k be Inferred or Specified?  It's Specified for C,+   but not mentioned in F's declaration.++ * In which order should the Specified variables a and b occur?+   It's clearly 'a' then 'b' in C's declaration, but the L-R ordering+   in F's declaration is 'b' then 'a'.++In both cases we make the choice by looking at F's declaration alone,+so it gets the kind+   F :: forall {k}. forall b a. b a -> Type++How it works+~~~~~~~~~~~~+These design choices are implemented by two completely different code+paths for++  * Declarations with a standalone kind signature or a complete user-specified+    kind signature (CUSK). Handled by the kcCheckDeclHeader.++  * Declarations without a kind signature (standalone or CUSK) are handled by+    kcInferDeclHeader; see Note [Inferring kinds for type declarations].++Note that neither code path worries about point (4) above, as this+is nicely handled by not mangling the res_kind. (Mangling res_kinds is done+*after* all this stuff, in tcDataDefn's call to etaExpandAlgTyCon.)++We can tell Inferred apart from Specified by looking at the scoped+tyvars; Specified are always included there.++Design alternatives+~~~~~~~~~~~~~~~~~~~+* For associated types we considered putting the class variables+  before the local variables, in a nod to the treatment for class+  methods. But it got too compilicated; see #15592, comment:21ff.++* We rigidly require the ordering above, even though we could be much more+  permissive. Relevant musings are at+  https://gitlab.haskell.org/ghc/ghc/issues/15743#note_161623+  The bottom line conclusion is that, if the user wants a different ordering,+  then can specify it themselves, and it is better to be predictable and dumb+  than clever and capricious.++  I (Richard) conjecture we could be fully permissive, allowing all classes+  of variables to intermix. We would have to augment ScopedSort to refuse to+  reorder Required variables (or check that it wouldn't have). But this would+  allow more programs. See #15743 for examples. Interestingly, Idris seems+  to allow this intermixing. The intermixing would be fully specified, in that+  we can be sure that inference wouldn't change between versions. However,+  would users be able to predict it? That I cannot answer.++Test cases (and tickets) relevant to these design decisions+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  T15591*+  T15592*+  T15743*++Note [Inferring kinds for type declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This note deals with /inference/ for type declarations+that do not have a CUSK.  Consider+  data T (a :: k1) k2 (x :: k2) = MkT (S a k2 x)+  data S (b :: k3) k4 (y :: k4) = MkS (T b k4 y)++We do kind inference as follows:++* Step 1: inferInitialKinds, and in particular kcInferDeclHeader.+  Make a unification variable for each of the Required and Specified+  type varialbes in the header.++  Record the connection between the Names the user wrote and the+  fresh unification variables in the tcTyConScopedTyVars field+  of the TcTyCon we are making+      [ (a,  aa)+      , (k1, kk1)+      , (k2, kk2)+      , (x,  xx) ]+  (I'm using the convention that double letter like 'aa' or 'kk'+  mean a unification variable.)++  These unification variables+    - Are TyVarTvs: that is, unification variables that can+      unify only with other type variables.+      See Note [Signature skolems] in TcType++    - Have complete fresh Names; see TcMType+      Note [Unification variables need fresh Names]++  Assign initial monomorophic kinds to S, T+          T :: kk1 -> * -> kk2 -> *+          S :: kk3 -> * -> kk4 -> *++* Step 2: kcTyClDecl. Extend the environment with a TcTyCon for S and+  T, with these monomophic kinds.  Now kind-check the declarations,+  and solve the resulting equalities.  The goal here is to discover+  constraints on all these unification variables.++  Here we find that kk1 := kk3, and kk2 := kk4.++  This is why we can't use skolems for kk1 etc; they have to+  unify with each other.++* Step 3: generaliseTcTyCon. Generalise each TyCon in turn.+  We find the free variables of the kind, skolemise them,+  sort them out into Inferred/Required/Specified (see the above+  Note [Required, Specified, and Inferred for types]),+  and perform some validity checks.++  This makes the utterly-final TyConBinders for the TyCon.++  All this is very similar at the level of terms: see TcBinds+  Note [Quantified variables in partial type signatures]++  But there some tricky corners: Note [Tricky scoping in generaliseTcTyCon]++* Step 4.  Extend the type environment with a TcTyCon for S and T, now+  with their utterly-final polymorphic kinds (needed for recursive+  occurrences of S, T).  Now typecheck the declarations, and build the+  final AlgTyCOn for S and T resp.++The first three steps are in kcTyClGroup; the fourth is in+tcTyClDecls.++There are some wrinkles++* Do not default TyVarTvs.  We always want to kind-generalise over+  TyVarTvs, and /not/ default them to Type. By definition a TyVarTv is+  not allowed to unify with a type; it must stand for a type+  variable. Hence the check in TcSimplify.defaultTyVarTcS, and+  TcMType.defaultTyVar.  Here's another example (#14555):+     data Exp :: [TYPE rep] -> TYPE rep -> Type where+        Lam :: Exp (a:xs) b -> Exp xs (a -> b)+  We want to kind-generalise over the 'rep' variable.+  #14563 is another example.++* Duplicate type variables. Consider #11203+    data SameKind :: k -> k -> *+    data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b)+  Here we will unify k1 with k2, but this time doing so is an error,+  because k1 and k2 are bound in the same declaration.++  We spot this during validity checking (findDupTyVarTvs),+  in generaliseTcTyCon.++* Required arguments.  Even the Required arguments should be made+  into TyVarTvs, not skolems.  Consider+    data T k (a :: k)+  Here, k is a Required, dependent variable. For uniformity, it is helpful+  to have k be a TyVarTv, in parallel with other dependent variables.++* Duplicate skolemisation is expected.  When generalising in Step 3,+  we may find that one of the variables we want to quantify has+  already been skolemised.  For example, suppose we have already+  generalise S. When we come to T we'll find that kk1 (now the same as+  kk3) has already been skolemised.++  That's fine -- but it means that+    a) when collecting quantification candidates, in+       candidateQTyVarsOfKind, we must collect skolems+    b) quantifyTyVars should be a no-op on such a skolem++Note [Tricky scoping in generaliseTcTyCon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider #16342+  class C (a::ka) x where+    cop :: D a x => x -> Proxy a -> Proxy a+    cop _ x = x :: Proxy (a::ka)++  class D (b::kb) y where+    dop :: C b y => y -> Proxy b -> Proxy b+    dop _ x = x :: Proxy (b::kb)++C and D are mutually recursive, by the time we get to+generaliseTcTyCon we'll have unified kka := kkb.++But when typechecking the default declarations for 'cop' and 'dop' in+tcDlassDecl2 we need {a, ka} and {b, kb} respectively to be in scope.+But at that point all we have is the utterly-final Class itself.++Conclusion: the classTyVars of a class must have the same Name as+that originally assigned by the user.  In our example, C must have+classTyVars {a, ka, x} while D has classTyVars {a, kb, y}.  Despite+the fact that kka and kkb got unified!++We achieve this sleight of hand in generaliseTcTyCon, using+the specialised function zonkRecTyVarBndrs.  We make the call+   zonkRecTyVarBndrs [ka,a,x] [kkb,aa,xxx]+where the [ka,a,x] are the Names originally assigned by the user, and+[kkb,aa,xx] are the corresponding (post-zonking, skolemised) TcTyVars.+zonkRecTyVarBndrs builds a recursive ZonkEnv that binds+   kkb :-> (ka :: <zonked kind of kkb>)+   aa  :-> (a  :: <konked kind of aa>)+   etc+That is, it maps each skolemised TcTyVars to the utterly-final+TyVar to put in the class, with its correct user-specified name.+When generalising D we'll do the same thing, but the ZonkEnv will map+   kkb :-> (kb :: <zonked kind of kkb>)+   bb  :-> (b  :: <konked kind of bb>)+   etc+Note that 'kkb' again appears in the domain of the mapping, but this+time mapped to 'kb'.  That's how C and D end up with differently-named+final TyVars despite the fact that we unified kka:=kkb++zonkRecTyVarBndrs we need to do knot-tying because of the need to+apply this same substitution to the kind of each.  -}++--------------+tcExtendKindEnvWithTyCons :: [TcTyCon] -> TcM a -> TcM a+tcExtendKindEnvWithTyCons tcs+  = tcExtendKindEnvList [ (tyConName tc, ATcTyCon tc) | tc <- tcs ]++--------------+mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv+-- Maps each tycon/datacon to a suitable promotion error+--    tc :-> APromotionErr TyConPE+--    dc :-> APromotionErr RecDataConPE+--    See Note [Recursion and promoting data constructors]++mkPromotionErrorEnv decls+  = foldr (plusNameEnv . mk_prom_err_env . unLoc)+          emptyNameEnv decls++mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv+mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats })+  = unitNameEnv nm (APromotionErr ClassPE)+    `plusNameEnv`+    mkNameEnv [ (name, APromotionErr TyConPE)+              | (dL->L _ (FamilyDecl { fdLName = (dL->L _ name) })) <- ats ]++mk_prom_err_env (DataDecl { tcdLName = (dL->L _ name)+                          , tcdDataDefn = HsDataDefn { dd_cons = cons } })+  = unitNameEnv name (APromotionErr TyConPE)+    `plusNameEnv`+    mkNameEnv [ (con, APromotionErr RecDataConPE)+              | (dL->L _ con') <- cons+              , (dL->L _ con)  <- getConNames con' ]++mk_prom_err_env decl+  = unitNameEnv (tcdName decl) (APromotionErr TyConPE)+    -- Works for family declarations too++--------------+inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon]+-- Returns a TcTyCon for each TyCon bound by the decls,+-- each with its initial kind++inferInitialKinds decls+  = do { traceTc "inferInitialKinds {" $ ppr (map (tcdName . unLoc) decls)+       ; tcs <- concatMapM infer_initial_kind decls+       ; traceTc "inferInitialKinds done }" empty+       ; return tcs }+  where+    infer_initial_kind = addLocM (getInitialKind InitialKindInfer)++-- Check type/class declarations against their standalone kind signatures or+-- CUSKs, producing a generalized TcTyCon for each.+checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TcTyCon]+checkInitialKinds decls+  = do { traceTc "checkInitialKinds {" $ ppr (mapFst (tcdName . unLoc) decls)+       ; tcs <- concatMapM check_initial_kind decls+       ; traceTc "checkInitialKinds done }" empty+       ; return tcs }+  where+    check_initial_kind (ldecl, msig) =+      addLocM (getInitialKind (InitialKindCheck msig)) ldecl++-- | Get the initial kind of a TyClDecl, either generalized or non-generalized,+-- depending on the 'InitialKindStrategy'.+getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon]++-- Allocate a fresh kind variable for each TyCon and Class+-- For each tycon, return a TcTyCon with kind k+-- where k is the kind of tc, derived from the LHS+--         of the definition (and probably including+--         kind unification variables)+--      Example: data T a b = ...+--      return (T, kv1 -> kv2 -> kv3)+--+-- This pass deals with (ie incorporates into the kind it produces)+--   * The kind signatures on type-variable binders+--   * The result kinds signature on a TyClDecl+--+-- No family instances are passed to checkInitialKinds/inferInitialKinds+getInitialKind strategy+    (ClassDecl { tcdLName = dL->L _ name+               , tcdTyVars = ktvs+               , tcdATs = ats })+  = do { cls <- kcDeclHeader strategy name ClassFlavour ktvs $+                return (TheKind constraintKind)+       ; let parent_tv_prs = tcTyConScopedTyVars cls+            -- See Note [Don't process associated types in getInitialKind]+       ; inner_tcs <-+           tcExtendNameTyVarEnv parent_tv_prs $+           mapM (addLocM (getAssocFamInitialKind cls)) ats+       ; return (cls : inner_tcs) }+  where+    getAssocFamInitialKind cls =+      case strategy of+        InitialKindInfer -> get_fam_decl_initial_kind (Just cls)+        InitialKindCheck _ -> check_initial_kind_assoc_fam cls++getInitialKind strategy+    (DataDecl { tcdLName = dL->L _ name+              , tcdTyVars = ktvs+              , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig+                                         , dd_ND = new_or_data } })+  = do  { let flav = newOrDataToFlavour new_or_data+              ctxt = DataKindCtxt name+        ; tc <- kcDeclHeader strategy name flav ktvs $+                case m_sig of+                  Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig+                  Nothing -> dataDeclDefaultResultKind new_or_data+        ; return [tc] }++getInitialKind InitialKindInfer (FamDecl { tcdFam = decl })+  = do { tc <- get_fam_decl_initial_kind Nothing decl+       ; return [tc] }++getInitialKind (InitialKindCheck msig) (FamDecl { tcdFam =+  FamilyDecl { fdLName     = unLoc -> name+             , fdTyVars    = ktvs+             , fdResultSig = unLoc -> resultSig+             , fdInfo      = info } } )+  = do { let flav = getFamFlav Nothing info+             ctxt = TyFamResKindCtxt name+       ; tc <- kcDeclHeader (InitialKindCheck msig) name flav ktvs $+               case famResultKindSignature resultSig of+                 Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig+                 Nothing ->+                   case msig of+                     CUSK -> return (TheKind liftedTypeKind)+                     SAKS _ -> return AnyKind+       ; return [tc] }++getInitialKind strategy+    (SynDecl { tcdLName = dL->L _ name+             , tcdTyVars = ktvs+             , tcdRhs = rhs })+  = do { let ctxt = TySynKindCtxt name+       ; tc <- kcDeclHeader strategy name TypeSynonymFlavour ktvs $+               case hsTyKindSig rhs of+                 Just rhs_sig -> TheKind <$> tcLHsKindSig ctxt rhs_sig+                 Nothing -> return AnyKind+       ; return [tc] }++getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec+getInitialKind _ (FamDecl {tcdFam = XFamilyDecl nec}) = noExtCon nec+getInitialKind _ (XTyClDecl nec) = noExtCon nec++get_fam_decl_initial_kind+  :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls+  -> FamilyDecl GhcRn+  -> TcM TcTyCon+get_fam_decl_initial_kind mb_parent_tycon+    FamilyDecl { fdLName     = (dL->L _ name)+               , fdTyVars    = ktvs+               , fdResultSig = (dL->L _ resultSig)+               , fdInfo      = info }+  = kcDeclHeader InitialKindInfer name flav ktvs $+    case resultSig of+      KindSig _ ki                              -> TheKind <$> tcLHsKindSig ctxt ki+      TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki+      _ -- open type families have * return kind by default+        | tcFlavourIsOpen flav              -> return (TheKind liftedTypeKind)+               -- closed type families have their return kind inferred+               -- by default+        | otherwise                         -> return AnyKind+  where+    flav = getFamFlav mb_parent_tycon info+    ctxt = TyFamResKindCtxt name+get_fam_decl_initial_kind _ (XFamilyDecl nec) = noExtCon nec++-- See Note [Standalone kind signatures for associated types]+check_initial_kind_assoc_fam+  :: TcTyCon -- parent class+  -> FamilyDecl GhcRn+  -> TcM TcTyCon+check_initial_kind_assoc_fam cls+  FamilyDecl+    { fdLName     = unLoc -> name+    , fdTyVars    = ktvs+    , fdResultSig = unLoc -> resultSig+    , fdInfo      = info }+  = kcDeclHeader (InitialKindCheck CUSK) name flav ktvs $+    case famResultKindSignature resultSig of+      Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig+      Nothing -> return (TheKind liftedTypeKind)+  where+    ctxt = TyFamResKindCtxt name+    flav = getFamFlav (Just cls) info+check_initial_kind_assoc_fam _ (XFamilyDecl nec) = noExtCon nec++{- Note [Standalone kind signatures for associated types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++If associated types had standalone kind signatures, would they wear them++---------------------------+------------------------------+  like this? (OUT)         |   or like this? (IN)+---------------------------+------------------------------+  type T :: Type -> Type   |   class C a where+  class C a where          |     type T :: Type -> Type+    type T a               |     type T a++The (IN) variant is syntactically ambiguous:++  class C a where+    type T :: a   -- standalone kind signature?+    type T :: a   -- declaration header?++The (OUT) variant does not suffer from this issue, but it might not be the+direction in which we want to take Haskell: we seek to unify type families and+functions, and, by extension, associated types with class methods. And yet we+give class methods their signatures inside the class, not outside. Neither do+we have the counterpart of InstanceSigs for StandaloneKindSignatures.++For now, we dodge the question by using CUSKs for associated types instead of+standalone kind signatures. This is a simple addition to the rule we used to+have before standalone kind signatures:++  old rule:  associated type has a CUSK iff its parent class has a CUSK+  new rule:  associated type has a CUSK iff its parent class has a CUSK or a standalone kind signature++-}++-- See Note [Data declaration default result kind]+dataDeclDefaultResultKind :: NewOrData -> TcM ContextKind+dataDeclDefaultResultKind new_or_data = do+  -- See Note [Implementation of UnliftedNewtypes]+  unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes+  return $ case new_or_data of+    NewType | unlifted_newtypes -> OpenKind+    _ -> TheKind liftedTypeKind++{- Note [Data declaration default result kind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When the user has not written an inline result kind annotation on a data+declaration, we assume it to be 'Type'. That is, the following declarations+D1 and D2 are considered equivalent:++  data D1         where ...+  data D2 :: Type where ...++The consequence of this assumption is that we reject D3 even though we+accept D4:++  data D3 where+    MkD3 :: ... -> D3 param++  data D4 :: Type -> Type where+    MkD4 :: ... -> D4 param++However, there's a twist: when -XUnliftedNewtypes are enabled, we must relax+the assumed result kind to (TYPE r) for newtypes:++  newtype D5 where+    MkD5 :: Int# -> D5++dataDeclDefaultResultKind takes care to produce the appropriate result kind.+-}++---------------------------------+getFamFlav+  :: Maybe TcTyCon    -- ^ Just cls <=> this is an associated family of class cls+  -> FamilyInfo pass+  -> TyConFlavour+getFamFlav mb_parent_tycon info =+  case info of+    DataFamily         -> DataFamilyFlavour mb_parent_tycon+    OpenTypeFamily     -> OpenTypeFamilyFlavour mb_parent_tycon+    ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon ) -- See Note [Closed type family mb_parent_tycon]+                          ClosedTypeFamilyFlavour++{- Note [Closed type family mb_parent_tycon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There's no way to write a closed type family inside a class declaration:++  class C a where+    type family F a where  -- error: parse error on input ‘where’++In fact, it is not clear what the meaning of such a declaration would be.+Therefore, 'mb_parent_tycon' of any closed type family has to be Nothing.+-}++------------------------------------------------------------------------+kcLTyClDecl :: LTyClDecl GhcRn -> TcM ()+  -- See Note [Kind checking for type and class decls]+kcLTyClDecl (dL->L loc decl)+  = setSrcSpan loc $+    tcAddDeclCtxt decl $+    do { traceTc "kcTyClDecl {" (ppr tc_name)+       ; kcTyClDecl decl+       ; traceTc "kcTyClDecl done }" (ppr tc_name) }+  where+    tc_name = tyClDeclLName decl++kcTyClDecl :: TyClDecl GhcRn -> TcM ()+-- This function is used solely for its side effect on kind variables+-- NB kind signatures on the type variables and+--    result kind signature have already been dealt with+--    by inferInitialKind, so we can ignore them here.++kcTyClDecl (DataDecl { tcdLName    = (dL->L _ name)+                     , tcdDataDefn = defn })+  | HsDataDefn { dd_cons = cons@((dL->L _ (ConDeclGADT {})) : _)+               , dd_ctxt = (dL->L _ [])+               , dd_ND = new_or_data } <- defn+  = do { tyCon <- kcLookupTcTyCon name+         -- See Note [Implementation of UnliftedNewtypes] STEP 2+       ; kcConDecls new_or_data (tyConResKind tyCon) cons+       }+    -- hs_tvs and dd_kindSig already dealt with in inferInitialKind+    -- This must be a GADT-style decl,+    --        (see invariants of DataDefn declaration)+    -- so (a) we don't need to bring the hs_tvs into scope, because the+    --        ConDecls bind all their own variables+    --    (b) dd_ctxt is not allowed for GADT-style decls, so we can ignore it++  | HsDataDefn { dd_ctxt = ctxt+               , dd_cons = cons+               , dd_ND = new_or_data } <- defn+  = bindTyClTyVars name $ \ _ _ ->+    do { _ <- tcHsContext ctxt+       ; tyCon <- kcLookupTcTyCon name+       ; kcConDecls new_or_data (tyConResKind tyCon) cons+       }++kcTyClDecl (SynDecl { tcdLName = dL->L _ name, tcdRhs = rhs })+  = bindTyClTyVars name $ \ _ res_kind ->+    discardResult $ tcCheckLHsType rhs res_kind+        -- NB: check against the result kind that we allocated+        -- in inferInitialKinds.++kcTyClDecl (ClassDecl { tcdLName = (dL->L _ name)+                      , tcdCtxt = ctxt, tcdSigs = sigs })+  = bindTyClTyVars name $ \ _ _ ->+    do  { _ <- tcHsContext ctxt+        ; mapM_ (wrapLocM_ kc_sig) sigs }+  where+    kc_sig (ClassOpSig _ _ nms op_ty) = kcClassSigType skol_info nms op_ty+    kc_sig _                          = return ()++    skol_info = TyConSkol ClassFlavour name++kcTyClDecl (FamDecl _ (FamilyDecl { fdLName  = (dL->L _ fam_tc_name)+                                  , fdInfo   = fd_info }))+-- closed type families look at their equations, but other families don't+-- do anything here+  = case fd_info of+      ClosedTypeFamily (Just eqns) ->+        do { fam_tc <- kcLookupTcTyCon fam_tc_name+           ; mapM_ (kcTyFamInstEqn fam_tc) eqns }+      _ -> return ()+kcTyClDecl (FamDecl _ (XFamilyDecl nec))        = noExtCon nec+kcTyClDecl (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec+kcTyClDecl (XTyClDecl nec)                      = noExtCon nec++-------------------++-- | Unify the kind of the first type provided with the newtype's kind, if+-- -XUnliftedNewtypes is enabled and the NewOrData indicates Newtype. If there+-- is more than one type provided, do nothing: the newtype is in error, and this+-- will be caught in validity checking (which will give a better error than we can+-- here.)+unifyNewtypeKind :: DynFlags+                 -> NewOrData+                 -> [LHsType GhcRn]   -- user-written argument types, should be just 1+                 -> [TcType]          -- type-checked argument types, should be just 1+                 -> TcKind            -- expected kind of newtype+                 -> TcM [TcType]      -- casted argument types (should be just 1)+                                      --  result = orig_arg |> kind_co+                                      -- where kind_co :: orig_arg_ki ~N expected_ki+unifyNewtypeKind dflags NewType [hs_ty] [tc_ty] ki+  | xopt LangExt.UnliftedNewtypes dflags+  = do { traceTc "unifyNewtypeKind" (ppr hs_ty $$ ppr tc_ty $$ ppr ki)+       ; co <- unifyKind (Just (unLoc hs_ty)) (typeKind tc_ty) ki+       ; return [tc_ty `mkCastTy` co] }+  -- See comments above: just do nothing here+unifyNewtypeKind _ _ _ arg_tys _ = return arg_tys++-- Type check the types of the arguments to a data constructor.+-- This includes doing kind unification if the type is a newtype.+-- See Note [Implementation of UnliftedNewtypes] for why we need+-- the first two arguments.+kcConArgTys :: NewOrData -> Kind -> [LHsType GhcRn] -> TcM ()+kcConArgTys new_or_data res_kind arg_tys = do+  { arg_tc_tys <- mapM (tcHsOpenType . getBangType) arg_tys+    -- See Note [Implementation of UnliftedNewtypes], STEP 2+  ; dflags <- getDynFlags+  ; discardResult $+      unifyNewtypeKind dflags new_or_data arg_tys arg_tc_tys res_kind+  }++kcConDecls :: NewOrData+           -> Kind             -- The result kind signature+           -> [LConDecl GhcRn] -- The data constructors+           -> TcM ()+kcConDecls new_or_data res_kind cons+  = mapM_ (wrapLocM_ (kcConDecl new_or_data final_res_kind)) cons+  where+    (_, final_res_kind) = splitPiTys res_kind+        -- See Note [kcConDecls result kind]++-- Kind check a data constructor. In additional to the data constructor,+-- we also need to know about whether or not its corresponding type was+-- declared with data or newtype, and we need to know the result kind of+-- this type. See Note [Implementation of UnliftedNewtypes] for why+-- we need the first two arguments.+kcConDecl :: NewOrData+          -> Kind  -- Result kind of the type constructor+                   -- Usually Type but can be TYPE UnliftedRep+                   -- or even TYPE r, in the case of unlifted newtype+          -> ConDecl GhcRn+          -> TcM ()+kcConDecl new_or_data res_kind (ConDeclH98+  { con_name = name, con_ex_tvs = ex_tvs+  , con_mb_cxt = ex_ctxt, con_args = args })+  = addErrCtxt (dataConCtxtName [name]) $+    discardResult                   $+    bindExplicitTKBndrs_Tv ex_tvs $+    do { _ <- tcHsMbContext ex_ctxt+       ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args)+         -- We don't need to check the telescope here,+         -- because that's done in tcConDecl+       }++kcConDecl new_or_data res_kind (ConDeclGADT+    { con_names = names, con_qvars = qtvs, con_mb_cxt = cxt+    , con_args = args, con_res_ty = res_ty })+  | HsQTvs { hsq_ext = implicit_tkv_nms+           , hsq_explicit = explicit_tkv_nms } <- qtvs+  = -- Even though the GADT-style data constructor's type is closed,+    -- we must still kind-check the type, because that may influence+    -- the inferred kind of the /type/ constructor.  Example:+    --    data T f a where+    --      MkT :: f a -> T f a+    -- If we don't look at MkT we won't get the correct kind+    -- for the type constructor T+    addErrCtxt (dataConCtxtName names) $+    discardResult $+    bindImplicitTKBndrs_Tv implicit_tkv_nms $+    bindExplicitTKBndrs_Tv explicit_tkv_nms $+        -- Why "_Tv"?  See Note [Kind-checking for GADTs]+    do { _ <- tcHsMbContext cxt+       ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args)+       ; _ <- tcHsOpenType res_ty+       ; return () }+kcConDecl _ _ (ConDeclGADT _ _ _ (XLHsQTyVars nec) _ _ _ _) = noExtCon nec+kcConDecl _ _ (XConDecl nec) = noExtCon nec++{- Note [kcConDecls result kind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We might have e.g.+    data T a :: Type -> Type where ...+or+    newtype instance N a :: Type -> Type  where ..+in which case, the 'res_kind' passed to kcConDecls will be+   Type->Type++We must look past those arrows, or even foralls, to the Type in the+corner, to pass to kcConDecl c.f. #16828. Hence the splitPiTys here.++I am a bit concerned about tycons with a declaration like+   data T a :: Type -> forall k. k -> Type  where ...++It does not have a CUSK, so kcInferDeclHeader will make a TcTyCon+with tyConResKind of Type -> forall k. k -> Type.  Even that is fine:+the splitPiTys will look past the forall.  But I'm bothered about+what if the type "in the corner" metions k?  This is incredibly+obscure but something like this could be bad:+   data T a :: Type -> foral k. k -> TYPE (F k) where ...++I bet we are not quite right here, but my brain suffered a buffer+overflow and I thought it best to nail the common cases right now.++Note [Recursion and promoting data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't want to allow promotion in a strongly connected component+when kind checking.++Consider:+  data T f = K (f (K Any))++When kind checking the `data T' declaration the local env contains the+mappings:+  T -> ATcTyCon <some initial kind>+  K -> APromotionErr++APromotionErr is only used for DataCons, and only used during type checking+in tcTyClGroup.++Note [Kind-checking for GADTs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  data Proxy a where+    MkProxy1 :: forall k (b :: k). Proxy b+    MkProxy2 :: forall j (c :: j). Proxy c++It seems reasonable that this should be accepted. But something very strange+is going on here: when we're kind-checking this declaration, we need to unify+the kind of `a` with k and j -- even though k and j's scopes are local to the type of+MkProxy{1,2}. The best approach we've come up with is to use TyVarTvs during+the kind-checking pass. First off, note that it's OK if the kind-checking pass+is too permissive: we'll snag the problems in the type-checking pass later.+(This extra permissiveness might happen with something like++  data SameKind :: k -> k -> Type+  data Bad a where+    MkBad :: forall k1 k2 (a :: k1) (b :: k2). Bad (SameKind a b)++which would be accepted if k1 and k2 were TyVarTvs. This is correctly rejected+in the second pass, though. Test case: polykinds/TyVarTvKinds3)+Recall that the kind-checking pass exists solely to collect constraints+on the kinds and to power unification.++To achieve the use of TyVarTvs, we must be careful to use specialized functions+that produce TyVarTvs, not ordinary skolems. This is why we need+kcExplicitTKBndrs and kcImplicitTKBndrs in TcHsType, separate from their+tc... variants.++The drawback of this approach is sometimes it will accept a definition that+a (hypothetical) declarative specification would likely reject. As a general+rule, we don't want to allow polymorphic recursion without a CUSK. Indeed,+the whole point of CUSKs is to allow polymorphic recursion. Yet, the TyVarTvs+approach allows a limited form of polymorphic recursion *without* a CUSK.++To wit:+  data T a = forall k (b :: k). MkT (T b) Int+  (test case: dependent/should_compile/T14066a)++Note that this is polymorphically recursive, with the recursive occurrence+of T used at a kind other than a's kind. The approach outlined here accepts+this definition, because this kind is still a kind variable (and so the+TyVarTvs unify). Stepping back, I (Richard) have a hard time envisioning a+way to describe exactly what declarations will be accepted and which will+be rejected (without a CUSK). However, the accepted definitions are indeed+well-kinded and any rejected definitions would be accepted with a CUSK,+and so this wrinkle need not cause anyone to lose sleep.++************************************************************************+*                                                                      *+\subsection{Type checking}+*                                                                      *+************************************************************************++Note [Type checking recursive type and class declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+At this point we have completed *kind-checking* of a mutually+recursive group of type/class decls (done in kcTyClGroup). However,+we discarded the kind-checked types (eg RHSs of data type decls);+note that kcTyClDecl returns ().  There are two reasons:++  * It's convenient, because we don't have to rebuild a+    kinded HsDecl (a fairly elaborate type)++  * It's necessary, because after kind-generalisation, the+    TyCons/Classes may now be kind-polymorphic, and hence need+    to be given kind arguments.++Example:+       data T f a = MkT (f a) (T f a)+During kind-checking, we give T the kind T :: k1 -> k2 -> *+and figure out constraints on k1, k2 etc. Then we generalise+to get   T :: forall k. (k->*) -> k -> *+So now the (T f a) in the RHS must be elaborated to (T k f a).++However, during tcTyClDecl of T (above) we will be in a recursive+"knot". So we aren't allowed to look at the TyCon T itself; we are only+allowed to put it (lazily) in the returned structures.  But when+kind-checking the RHS of T's decl, we *do* need to know T's kind (so+that we can correctly elaboarate (T k f a).  How can we get T's kind+without looking at T?  Delicate answer: during tcTyClDecl, we extend++  *Global* env with T -> ATyCon (the (not yet built) final TyCon for T)+  *Local*  env with T -> ATcTyCon (TcTyCon with the polymorphic kind of T)++Then:++  * During TcHsType.tcTyVar we look in the *local* env, to get the+    fully-known, not knot-tied TcTyCon for T.++  * Then, in TcHsSyn.zonkTcTypeToType (and zonkTcTyCon in particular)+    we look in the *global* env to get the TyCon.++This fancy footwork (with two bindings for T) is only necessary for the+TyCons or Classes of this recursive group.  Earlier, finished groups,+live in the global env only.++See also Note [Kind checking recursive type and class declarations]++Note [Kind checking recursive type and class declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before we can type-check the decls, we must kind check them. This+is done by establishing an "initial kind", which is a rather uninformed+guess at a tycon's kind (by counting arguments, mainly) and then+using this initial kind for recursive occurrences.++The initial kind is stored in exactly the same way during+kind-checking as it is during type-checking (Note [Type checking+recursive type and class declarations]): in the *local* environment,+with ATcTyCon. But we still must store *something* in the *global*+environment. Even though we discard the result of kind-checking, we+sometimes need to produce error messages. These error messages will+want to refer to the tycons being checked, except that they don't+exist yet, and it would be Terribly Annoying to get the error messages+to refer back to HsSyn. So we create a TcTyCon and put it in the+global env. This tycon can print out its name and knows its kind, but+any other action taken on it will panic. Note that TcTyCons are *not*+knot-tied, unlike the rather valid but knot-tied ones that occur+during type-checking.++Note [Declarations for wired-in things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For wired-in things we simply ignore the declaration+and take the wired-in information.  That avoids complications.+e.g. the need to make the data constructor worker name for+     a constraint tuple match the wired-in one++Note [Implementation of UnliftedNewtypes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Expected behavior of UnliftedNewtypes:++* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0013-unlifted-newtypes.rst+* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/98++What follows is a high-level overview of the implementation of the+proposal.++STEP 1: Getting the initial kind, as done by inferInitialKind. We have+two sub-cases (assuming we have a newtype and -XUnliftedNewtypes is enabled):++* With a CUSK: no change in kind-checking; the tycon is given the kind+  the user writes, whatever it may be.++* Without a CUSK: If there is no kind signature, the tycon is given+  a kind `TYPE r`, for a fresh unification variable `r`.++STEP 2: Kind-checking, as done by kcTyClDecl. This step is skipped for CUSKs.+The key function here is kcConDecl, which looks at an individual constructor+declaration. In the unlifted-newtypes case (i.e., -XUnliftedNewtypes and,+indeed, we are processing a newtype), we call unifyNewtypeKind, which is a+thin wrapper around unifyKind, unifying the kind of the one argument and the+result kind of the newtype tycon.++Examples of newtypes affected by STEP 2, assuming -XUnliftedNewtypes is+enabled (we use r0 to denote a unification variable):++newtype Foo rep = MkFoo (forall (a :: TYPE rep). a)++ kcConDecl unifies (TYPE r0) with (TYPE rep), where (TYPE r0)+  is the kind that inferInitialKind invented for (Foo rep).++data Color = Red | Blue+type family Interpret (x :: Color) :: RuntimeRep where+  Interpret 'Red = 'IntRep+  Interpret 'Blue = 'WordRep+data family Foo (x :: Color) :: TYPE (Interpret x)+newtype instance Foo 'Red = FooRedC Int#++ kcConDecl unifies TYPE (Interpret 'Red) with TYPE 'IntRep++Note that, in the GADT case, we might have a kind signature with arrows+(newtype XYZ a b :: Type -> Type where ...). We want only the final+component of the kind for checking in kcConDecl, so we call etaExpandAlgTyCon+in kcTyClDecl.++STEP 3: Type-checking (desugaring), as done by tcTyClDecl. The key function+here is tcConDecl. Once again, we must call unifyNewtypeKind, for two reasons:++  A. It is possible that a GADT has a CUSK. (Note that this is *not*+     possible for H98 types. Recall that CUSK types don't go through+     kcTyClDecl, so we might not have done this kind check.+  B. We need to produce the coercion to put on the argument type+     if the kinds are different (for both H98 and GADT).++Example of (B):++type family F a where+  F Int = LiftedRep++newtype N :: TYPE (F Int) where+  MkN :: Int -> N++We really need to have the argument to MkN be (Int |> TYPE (sym axF)), where+axF :: F Int ~ LiftedRep. That way, the argument kind is the same as the+newtype kind, which is the principal correctness condition for newtypes.+This call to unifyNewtypeKind is what produces that coercion.++Note that this is possible in the H98 case only for a data family, because+the H98 syntax doesn't permit a kind signature on the newtype itself.+++1. In tcFamDecl1, we suppress a tcIsLiftedTypeKind check if+   UnliftedNewtypes is on. This allows us to write things like:+     data family Foo :: TYPE 'IntRep++2. In a newtype instance (with -XUnliftedNewtypes), if the user does+   not write a kind signature, we want to allow the possibility that+   the kind is not Type, so we use newOpenTypeKind instead of liftedTypeKind.+   This is done in tcDataFamInstHeader in TcInstDcls. Example:++       data family Bar (a :: RuntimeRep) :: TYPE a+       newtype instance Bar 'IntRep = BarIntC Int#+       newtype instance Bar 'WordRep :: TYPE 'WordRep where+         BarWordC :: Word# -> Bar 'WordRep++   The data instance corresponding to IntRep does not specify a kind signature,+   so tc_kind_sig just returns `TYPE r0` (where `r0` is a fresh metavariable).+   The data instance corresponding to WordRep does have a kind signature, so+   we use that kind signature.++3. A data family and its newtype instance may be declared with slightly+   different kinds. See Note [Unifying data family kinds] in TcInstDcls.++There's also a change in the renamer:++* In RnSource.rnTyClDecl, enabling UnliftedNewtypes changes what is means+  for a newtype to have a CUSK. This is necessary since UnliftedNewtypes+  means that, for newtypes without kind signatures, we must use the field+  inside the data constructor to determine the result kind.+  See Note [Unlifted Newtypes and CUSKs] for more detail.++For completeness, it was also neccessary to make coerce work on+unlifted types, resolving #13595.++-}++tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo])+tcTyClDecl roles_info (dL->L loc decl)+  | Just thing <- wiredInNameTyThing_maybe (tcdName decl)+  = case thing of -- See Note [Declarations for wired-in things]+      ATyCon tc -> return (tc, wiredInDerivInfo tc decl)+      _ -> pprPanic "tcTyClDecl" (ppr thing)++  | otherwise+  = setSrcSpan loc $ tcAddDeclCtxt decl $+    do { traceTc "---- tcTyClDecl ---- {" (ppr decl)+       ; (tc, deriv_infos) <- tcTyClDecl1 Nothing roles_info decl+       ; traceTc "---- tcTyClDecl end ---- }" (ppr tc)+       ; return (tc, deriv_infos) }++noDerivInfos :: a -> (a, [DerivInfo])+noDerivInfos a = (a, [])++wiredInDerivInfo :: TyCon -> TyClDecl GhcRn -> [DerivInfo]+wiredInDerivInfo tycon decl+  | DataDecl { tcdDataDefn = dataDefn } <- decl+  , HsDataDefn { dd_derivs = derivs } <- dataDefn+  = [ DerivInfo { di_rep_tc = tycon+                , di_scoped_tvs =+                    if isFunTyCon tycon || isPrimTyCon tycon+                       then []  -- no tyConTyVars+                       else mkTyVarNamePairs (tyConTyVars tycon)+                , di_clauses = unLoc derivs+                , di_ctxt = tcMkDeclCtxt decl } ]+wiredInDerivInfo _ _ = []++  -- "type family" declarations+tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM (TyCon, [DerivInfo])+tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd })+  = fmap noDerivInfos $+    tcFamDecl1 parent fd++  -- "type" synonym declaration+tcTyClDecl1 _parent roles_info+            (SynDecl { tcdLName = (dL->L _ tc_name)+                     , tcdRhs   = rhs })+  = ASSERT( isNothing _parent )+    fmap noDerivInfos $+    bindTyClTyVars tc_name $ \ binders res_kind ->+    tcTySynRhs roles_info tc_name binders res_kind rhs++  -- "data/newtype" declaration+tcTyClDecl1 _parent roles_info+            decl@(DataDecl { tcdLName = (dL->L _ tc_name)+                           , tcdDataDefn = defn })+  = ASSERT( isNothing _parent )+    bindTyClTyVars tc_name $ \ tycon_binders res_kind ->+    tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name+               tycon_binders res_kind defn++tcTyClDecl1 _parent roles_info+            (ClassDecl { tcdLName = (dL->L _ class_name)+                       , tcdCtxt = hs_ctxt+                       , tcdMeths = meths+                       , tcdFDs = fundeps+                       , tcdSigs = sigs+                       , tcdATs = ats+                       , tcdATDefs = at_defs })+  = ASSERT( isNothing _parent )+    do { clas <- tcClassDecl1 roles_info class_name hs_ctxt+                              meths fundeps sigs ats at_defs+       ; return (noDerivInfos (classTyCon clas)) }++tcTyClDecl1 _ _ (XTyClDecl nec) = noExtCon nec+++{- *********************************************************************+*                                                                      *+          Class declarations+*                                                                      *+********************************************************************* -}++tcClassDecl1 :: RolesInfo -> Name -> LHsContext GhcRn+             -> LHsBinds GhcRn -> [LHsFunDep GhcRn] -> [LSig GhcRn]+             -> [LFamilyDecl GhcRn] -> [LTyFamDefltDecl GhcRn]+             -> TcM Class+tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs+  = fixM $ \ clas ->+    -- We need the knot because 'clas' is passed into tcClassATs+    bindTyClTyVars class_name $ \ binders res_kind ->+    do { checkClassKindSig res_kind+       ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders)+       ; let tycon_name = class_name        -- We use the same name+             roles = roles_info tycon_name  -- for TyCon and Class++       ; (ctxt, fds, sig_stuff, at_stuff)+            <- pushTcLevelM_   $+               solveEqualities $+               do { ctxt <- tcHsContext hs_ctxt+                  ; fds  <- mapM (addLocM tc_fundep) fundeps+                  ; sig_stuff <- tcClassSigs class_name sigs meths+                  ; at_stuff  <- tcClassATs class_name clas ats at_defs+                  ; return (ctxt, fds, sig_stuff, at_stuff) }++       -- The solveEqualities will report errors for any+       -- unsolved equalities, so these zonks should not encounter+       -- any unfilled coercion variables unless there is such an error+       -- The zonk also squeeze out the TcTyCons, and converts+       -- Skolems to tyvars.+       ; ze        <- emptyZonkEnv+       ; ctxt      <- zonkTcTypesToTypesX ze ctxt+       ; sig_stuff <- mapM (zonkTcMethInfoToMethInfoX ze) sig_stuff+         -- ToDo: do we need to zonk at_stuff?++       -- TODO: Allow us to distinguish between abstract class,+       -- and concrete class with no methods (maybe by+       -- specifying a trailing where or not++       ; mindef <- tcClassMinimalDef class_name sigs sig_stuff+       ; is_boot <- tcIsHsBootOrSig+       ; let body | is_boot, null ctxt, null at_stuff, null sig_stuff+                  = Nothing+                  | otherwise+                  = Just (ctxt, at_stuff, sig_stuff, mindef)++       ; clas <- buildClass class_name binders roles fds body+       ; traceTc "tcClassDecl" (ppr fundeps $$ ppr binders $$+                                ppr fds)+       ; return clas }+  where+    tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ;+                                ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ;+                                ; return (tvs1', tvs2') }+++{- Note [Associated type defaults]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The following is an example of associated type defaults:+             class C a where+               data D a++               type F a b :: *+               type F a b = [a]        -- Default++Note that we can get default definitions only for type families, not data+families.+-}++tcClassATs :: Name                    -- The class name (not knot-tied)+           -> Class                   -- The class parent of this associated type+           -> [LFamilyDecl GhcRn]     -- Associated types.+           -> [LTyFamDefltDecl GhcRn] -- Associated type defaults.+           -> TcM [ClassATItem]+tcClassATs class_name cls ats at_defs+  = do {  -- Complain about associated type defaults for non associated-types+         sequence_ [ failWithTc (badATErr class_name n)+                   | n <- map at_def_tycon at_defs+                   , not (n `elemNameSet` at_names) ]+       ; mapM tc_at ats }+  where+    at_def_tycon :: LTyFamDefltDecl GhcRn -> Name+    at_def_tycon (dL->L _ eqn) = tyFamInstDeclName eqn++    at_fam_name :: LFamilyDecl GhcRn -> Name+    at_fam_name (dL->L _ decl) = unLoc (fdLName decl)++    at_names = mkNameSet (map at_fam_name ats)++    at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn]+    -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs'+    at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv+                                          (at_def_tycon at_def) [at_def])+                        emptyNameEnv at_defs++    tc_at at = do { fam_tc <- addLocM (tcFamDecl1 (Just cls)) at+                  ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at)+                                  `orElse` []+                  ; atd <- tcDefaultAssocDecl fam_tc at_defs+                  ; return (ATI fam_tc atd) }++-------------------------+tcDefaultAssocDecl ::+     TyCon                                -- ^ Family TyCon (not knot-tied)+  -> [LTyFamDefltDecl GhcRn]              -- ^ Defaults+  -> TcM (Maybe (KnotTied Type, SrcSpan)) -- ^ Type checked RHS+tcDefaultAssocDecl _ []+  = return Nothing  -- No default declaration++tcDefaultAssocDecl _ (d1:_:_)+  = failWithTc (text "More than one default declaration for"+                <+> ppr (tyFamInstDeclName (unLoc d1)))++tcDefaultAssocDecl fam_tc+  [dL->L loc (TyFamInstDecl { tfid_eqn =+         HsIB { hsib_ext  = imp_vars+              , hsib_body = FamEqn { feqn_tycon = L _ tc_name+                                   , feqn_bndrs = mb_expl_bndrs+                                   , feqn_pats  = hs_pats+                                   , feqn_rhs   = hs_rhs_ty }}})]+  = -- See Note [Type-checking default assoc decls]+    setSrcSpan loc $+    tcAddFamInstCtxt (text "default type instance") tc_name $+    do { traceTc "tcDefaultAssocDecl 1" (ppr tc_name)+       ; let fam_tc_name = tyConName fam_tc+             vis_arity = length (tyConVisibleTyVars fam_tc)+             vis_pats  = numVisibleArgs hs_pats++       -- Kind of family check+       ; ASSERT( fam_tc_name == tc_name )+         checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)++       -- Arity check+       ; checkTc (vis_pats == vis_arity)+                 (wrongNumberOfParmsErr vis_arity)++       -- Typecheck RHS+       --+       -- You might think we should pass in some AssocInstInfo, as we're looking+       -- at an associated type. But this would be wrong, because an associated+       -- type default LHS can mention *different* type variables than the+       -- enclosing class. So it's treated more as a freestanding beast.+       ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc NotAssociated+                                                    imp_vars (mb_expl_bndrs `orElse` [])+                                                    hs_pats hs_rhs_ty++       ; let fam_tvs  = tyConTyVars fam_tc+             ppr_eqn  = ppr_default_eqn pats rhs_ty+             pats_vis = tyConArgFlags fam_tc pats+       ; traceTc "tcDefaultAssocDecl 2" (vcat+           [ text "fam_tvs" <+> ppr fam_tvs+           , text "qtvs"    <+> ppr qtvs+           , text "pats"    <+> ppr pats+           , text "rhs_ty"  <+> ppr rhs_ty+           ])+       ; pat_tvs <- zipWithM (extract_tv ppr_eqn) pats pats_vis+       ; check_all_distinct_tvs ppr_eqn $ zip pat_tvs pats_vis+       ; let subst = zipTvSubst pat_tvs (mkTyVarTys fam_tvs)+       ; pure $ Just (substTyUnchecked subst rhs_ty, loc)+           -- We also perform other checks for well-formedness and validity+           -- later, in checkValidClass+     }+  where+    -- Checks that a pattern on the LHS of a default is a type+    -- variable. If so, return the underlying type variable, and if+    -- not, throw an error.+    -- See Note [Type-checking default assoc decls]+    extract_tv :: SDoc    -- The pretty-printed default equation+                          -- (only used for error message purposes)+               -> Type    -- The particular type pattern from which to extract+                          -- its underlying type variable+               -> ArgFlag -- The visibility of the type pattern+                          -- (only used for error message purposes)+               -> TcM TyVar+    extract_tv ppr_eqn pat pat_vis =+      case getTyVar_maybe pat of+        Just tv -> pure tv+        Nothing -> failWithTc $+          pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $+          hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:")+             2 (vcat [ppr_eqn, suggestion])+++    -- Checks that no type variables in an associated default declaration are+    -- duplicated. If that is the case, throw an error.+    -- See Note [Type-checking default assoc decls]+    check_all_distinct_tvs ::+         SDoc               -- The pretty-printed default equation (only used+                            -- for error message purposes)+      -> [(TyVar, ArgFlag)] -- The type variable arguments in the associated+                            -- default declaration, along with their respective+                            -- visibilities (the latter are only used for error+                            -- message purposes)+      -> TcM ()+    check_all_distinct_tvs ppr_eqn pat_tvs_vis =+      let dups = findDupsEq ((==) `on` fst) pat_tvs_vis in+      traverse_+        (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $+               pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $+               hang (text "Illegal duplicate variable"+                       <+> quotes (ppr pat_tv) <+> text "in:")+                  2 (vcat [ppr_eqn, suggestion]))+        dups++    ppr_default_eqn :: [Type] -> Type -> SDoc+    ppr_default_eqn pats rhs_ty =+      quotes (text "type" <+> ppr (mkTyConApp fam_tc pats)+                <+> equals <+> ppr rhs_ty)++    suggestion :: SDoc+    suggestion = text "The arguments to" <+> quotes (ppr fam_tc)+             <+> text "must all be distinct type variables"+tcDefaultAssocDecl _ [_]+  = panic "tcDefaultAssocDecl: Impossible Match" -- due to #15884+++{- Note [Type-checking default assoc decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this default declaration for an associated type++   class C a where+      type F (a :: k) b :: Type+      type F (x :: j) y = Proxy x -> y++Note that the class variable 'a' doesn't scope over the default assoc+decl (rather oddly I think), and (less oddly) neither does the second+argument 'b' of the associated type 'F', or the kind variable 'k'.+Instead, the default decl is treated more like a top-level type+instance.++However we store the default rhs (Proxy x -> y) in F's TyCon, using+F's own type variables, so we need to convert it to (Proxy a -> b).+We do this by creating a substitution [j |-> k, x |-> a, b |-> y] and+applying this substitution to the RHS.++In order to create this substitution, we must first ensure that all of+the arguments in the default instance consist of distinct type variables.+One might think that this is a simple task that could be implemented earlier+in the compiler, perhaps in the parser or the renamer. However, there are some+tricky corner cases that really do require the full power of typechecking to+weed out, as the examples below should illustrate.++First, we must check that all arguments are type variables. As a motivating+example, consider this erroneous program (inspired by #11361):++   class C a where+      type F (a :: k) b :: Type+      type F x        b = x++If you squint, you'll notice that the kind of `x` is actually Type. However,+we cannot substitute from [Type |-> k], so we reject this default.++Next, we must check that all arguments are distinct. Here is another offending+example, this time taken from #13971:++   class C2 (a :: j) where+      type F2 (a :: j) (b :: k)+      type F2 (x :: z) y = SameKind x y+   data SameKind :: k -> k -> Type++All of the arguments in the default equation for `F2` are type variables, so+that passes the first check. However, if we were to build this substitution,+then both `j` and `k` map to `z`! In terms of visible kind application, it's as+if we had written `type F2 @z @z x y = SameKind @z x y`, which makes it clear+that we have duplicated a use of `z` on the LHS. Therefore, `F2`'s default is+also rejected.++Since the LHS of an associated type family default is always just variables,+it won't contain any tycons. Accordingly, the patterns used in the substitution+won't actually be knot-tied, even though we're in the knot. This is too+delicate for my taste, but it works.+-}++{- *********************************************************************+*                                                                      *+          Type family declarations+*                                                                      *+********************************************************************* -}++tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon+tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info+                              , fdLName = tc_lname@(dL->L _ tc_name)+                              , fdResultSig = (dL->L _ sig)+                              , fdInjectivityAnn = inj })+  | DataFamily <- fam_info+  = bindTyClTyVars tc_name $ \ binders res_kind -> do+  { traceTc "data family:" (ppr tc_name)+  ; checkFamFlag tc_name++  -- Check that the result kind is OK+  -- We allow things like+  --   data family T (a :: Type) :: forall k. k -> Type+  -- We treat T as having arity 1, but result kind forall k. k -> Type+  -- But we want to check that the result kind finishes in+  --   Type or a kind-variable+  -- For the latter, consider+  --   data family D a :: forall k. Type -> k+  -- When UnliftedNewtypes is enabled, we loosen this restriction+  -- on the return kind. See Note [Implementation of UnliftedNewtypes], wrinkle (1).+  ; let (_, final_res_kind) = splitPiTys res_kind+  ; checkDataKindSig DataFamilySort final_res_kind+  ; tc_rep_name <- newTyConRepName tc_name+  ; let inj   = Injective $ replicate (length binders) True+        tycon = mkFamilyTyCon tc_name binders+                              res_kind+                              (resultVariableName sig)+                              (DataFamilyTyCon tc_rep_name)+                              parent inj+  ; return tycon }++  | OpenTypeFamily <- fam_info+  = bindTyClTyVars tc_name $ \ binders res_kind -> do+  { traceTc "open type family:" (ppr tc_name)+  ; checkFamFlag tc_name+  ; inj' <- tcInjectivity binders inj+  ; checkResultSigFlag tc_name sig  -- check after injectivity for better errors+  ; let tycon = mkFamilyTyCon tc_name binders res_kind+                               (resultVariableName sig) OpenSynFamilyTyCon+                               parent inj'+  ; return tycon }++  | ClosedTypeFamily mb_eqns <- fam_info+  = -- Closed type families are a little tricky, because they contain the definition+    -- of both the type family and the equations for a CoAxiom.+    do { traceTc "Closed type family:" (ppr tc_name)+         -- the variables in the header scope only over the injectivity+         -- declaration but this is not involved here+       ; (inj', binders, res_kind)+            <- bindTyClTyVars tc_name $ \ binders res_kind ->+               do { inj' <- tcInjectivity binders inj+                  ; return (inj', binders, res_kind) }++       ; checkFamFlag tc_name -- make sure we have -XTypeFamilies+       ; checkResultSigFlag tc_name sig++         -- If Nothing, this is an abstract family in a hs-boot file;+         -- but eqns might be empty in the Just case as well+       ; case mb_eqns of+           Nothing   ->+               return $ mkFamilyTyCon tc_name binders res_kind+                                      (resultVariableName sig)+                                      AbstractClosedSynFamilyTyCon parent+                                      inj'+           Just eqns -> do {++         -- Process the equations, creating CoAxBranches+       ; let tc_fam_tc = mkTcTyCon tc_name binders res_kind+                                   noTcTyConScopedTyVars+                                   False {- this doesn't matter here -}+                                   ClosedTypeFamilyFlavour++       ; branches <- mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns+         -- Do not attempt to drop equations dominated by earlier+         -- ones here; in the case of mutual recursion with a data+         -- type, we get a knot-tying failure.  Instead we check+         -- for this afterwards, in TcValidity.checkValidCoAxiom+         -- Example: tc265++         -- Create a CoAxiom, with the correct src location.+       ; co_ax_name <- newFamInstAxiomName tc_lname []++       ; let mb_co_ax+              | null eqns = Nothing   -- mkBranchedCoAxiom fails on empty list+              | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches)++             fam_tc = mkFamilyTyCon tc_name binders res_kind (resultVariableName sig)+                      (ClosedSynFamilyTyCon mb_co_ax) parent inj'++         -- We check for instance validity later, when doing validity+         -- checking for the tycon. Exception: checking equations+         -- overlap done by dropDominatedAxioms+       ; return fam_tc } }++  | otherwise = panic "tcFamInst1"  -- Silence pattern-exhaustiveness checker+tcFamDecl1 _ (XFamilyDecl nec) = noExtCon nec++-- | Maybe return a list of Bools that say whether a type family was declared+-- injective in the corresponding type arguments. Length of the list is equal to+-- the number of arguments (including implicit kind/coercion arguments).+-- True on position+-- N means that a function is injective in its Nth argument. False means it is+-- not.+tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn)+              -> TcM Injectivity+tcInjectivity _ Nothing+  = return NotInjective++  -- User provided an injectivity annotation, so for each tyvar argument we+  -- check whether a type family was declared injective in that argument. We+  -- return a list of Bools, where True means that corresponding type variable+  -- was mentioned in lInjNames (type family is injective in that argument) and+  -- False means that it was not mentioned in lInjNames (type family is not+  -- injective in that type variable). We also extend injectivity information to+  -- kind variables, so if a user declares:+  --+  --   type family F (a :: k1) (b :: k2) = (r :: k3) | r -> a+  --+  -- then we mark both `a` and `k1` as injective.+  -- NB: the return kind is considered to be *input* argument to a type family.+  -- Since injectivity allows to infer input arguments from the result in theory+  -- we should always mark the result kind variable (`k3` in this example) as+  -- injective.  The reason is that result type has always an assigned kind and+  -- therefore we can always infer the result kind if we know the result type.+  -- But this does not seem to be useful in any way so we don't do it.  (Another+  -- reason is that the implementation would not be straightforward.)+tcInjectivity tcbs (Just (dL->L loc (InjectivityAnn _ lInjNames)))+  = setSrcSpan loc $+    do { let tvs = binderVars tcbs+       ; dflags <- getDynFlags+       ; checkTc (xopt LangExt.TypeFamilyDependencies dflags)+                 (text "Illegal injectivity annotation" $$+                  text "Use TypeFamilyDependencies to allow this")+       ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames+       ; inj_tvs <- mapM zonkTcTyVarToTyVar inj_tvs -- zonk the kinds+       ; let inj_ktvs = filterVarSet isTyVar $  -- no injective coercion vars+                        closeOverKinds (mkVarSet inj_tvs)+       ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs+       ; traceTc "tcInjectivity" (vcat [ ppr tvs, ppr lInjNames, ppr inj_tvs+                                       , ppr inj_ktvs, ppr inj_bools ])+       ; return $ Injective inj_bools }++tcTySynRhs :: RolesInfo+           -> Name+           -> [TyConBinder] -> Kind+           -> LHsType GhcRn -> TcM TyCon+tcTySynRhs roles_info tc_name binders res_kind hs_ty+  = do { env <- getLclEnv+       ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))+       ; rhs_ty <- pushTcLevelM_   $+                   solveEqualities $+                   tcCheckLHsType hs_ty res_kind+       ; rhs_ty <- zonkTcTypeToType rhs_ty+       ; let roles = roles_info tc_name+             tycon = buildSynTyCon tc_name binders res_kind roles rhs_ty+       ; return tycon }++tcDataDefn :: SDoc+           -> RolesInfo -> Name+           -> [TyConBinder] -> Kind+           -> HsDataDefn GhcRn -> TcM (TyCon, [DerivInfo])+  -- NB: not used for newtype/data instances (whether associated or not)+tcDataDefn err_ctxt+           roles_info+           tc_name tycon_binders res_kind+           (HsDataDefn { dd_ND = new_or_data, dd_cType = cType+                       , dd_ctxt = ctxt+                       , dd_kindSig = mb_ksig  -- Already in tc's kind+                                               -- via inferInitialKinds+                       , dd_cons = cons+                       , dd_derivs = derivs })+ =  do { gadt_syntax <- dataDeclChecks tc_name new_or_data ctxt cons++       ; tcg_env <- getGblEnv+       ; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind+       ; let hsc_src = tcg_src tcg_env+       ; unless (mk_permissive_kind hsc_src cons) $+           checkDataKindSig (DataDeclSort new_or_data) final_res_kind++       ; stupid_tc_theta <- pushTcLevelM_ $ solveEqualities $ tcHsContext ctxt+       ; stupid_theta    <- zonkTcTypesToTypes stupid_tc_theta+       ; kind_signatures <- xoptM LangExt.KindSignatures++             -- Check that we don't use kind signatures without Glasgow extensions+       ; when (isJust mb_ksig) $+         checkTc (kind_signatures) (badSigTyDecl tc_name)++       ; tycon <- fixM $ \ tycon -> do+             { let final_bndrs = tycon_binders `chkAppend` extra_bndrs+                   res_ty      = mkTyConApp tycon (mkTyVarTys (binderVars final_bndrs))+                   roles       = roles_info tc_name+             ; data_cons <- tcConDecls+                              tycon+                              new_or_data+                              final_bndrs+                              final_res_kind+                              res_ty+                              cons+             ; tc_rhs    <- mk_tc_rhs hsc_src tycon data_cons+             ; tc_rep_nm <- newTyConRepName tc_name+             ; return (mkAlgTyCon tc_name+                                  final_bndrs+                                  final_res_kind+                                  roles+                                  (fmap unLoc cType)+                                  stupid_theta tc_rhs+                                  (VanillaAlgTyCon tc_rep_nm)+                                  gadt_syntax) }+       ; tctc <- tcLookupTcTyCon tc_name+            -- 'tctc' is a 'TcTyCon' and has the 'tcTyConScopedTyVars' that we need+            -- unlike the finalized 'tycon' defined above which is an 'AlgTyCon'+       ; let deriv_info = DerivInfo { di_rep_tc = tycon+                                    , di_scoped_tvs = tcTyConScopedTyVars tctc+                                    , di_clauses = unLoc derivs+                                    , di_ctxt = err_ctxt }+       ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs)+       ; return (tycon, [deriv_info]) }+  where+    -- Abstract data types in hsig files can have arbitrary kinds,+    -- because they may be implemented by type synonyms+    -- (which themselves can have arbitrary kinds, not just *). See #13955.+    --+    -- Note that this is only a property that data type declarations possess,+    -- so one could not have, say, a data family instance in an hsig file that+    -- has kind `Bool`. Therfore, this check need only occur in the code that+    -- typechecks data type declarations.+    mk_permissive_kind HsigFile [] = True+    mk_permissive_kind _ _ = False++    -- In hs-boot, a 'data' declaration with no constructors+    -- indicates a nominally distinct abstract data type.+    mk_tc_rhs HsBootFile _ []+      = return AbstractTyCon++    mk_tc_rhs HsigFile _ [] -- ditto+      = return AbstractTyCon++    mk_tc_rhs _ tycon data_cons+      = case new_or_data of+          DataType -> return (mkDataTyConRhs data_cons)+          NewType  -> ASSERT( not (null data_cons) )+                      mkNewTyConRhs tc_name tycon (head data_cons)+tcDataDefn _ _ _ _ _ (XHsDataDefn nec) = noExtCon nec+++-------------------------+kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM ()+-- Used for the equations of a closed type family only+-- Not used for data/type instances+kcTyFamInstEqn tc_fam_tc+    (dL->L loc (HsIB { hsib_ext = imp_vars+                     , hsib_body = FamEqn { feqn_tycon = dL->L _ eqn_tc_name+                                          , feqn_bndrs = mb_expl_bndrs+                                          , feqn_pats  = hs_pats+                                          , feqn_rhs   = hs_rhs_ty }}))+  = setSrcSpan loc $+    do { traceTc "kcTyFamInstEqn" (vcat+           [ text "tc_name ="    <+> ppr eqn_tc_name+           , text "fam_tc ="     <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc)+           , text "hsib_vars ="  <+> ppr imp_vars+           , text "feqn_bndrs =" <+> ppr mb_expl_bndrs+           , text "feqn_pats ="  <+> ppr hs_pats ])+          -- this check reports an arity error instead of a kind error; easier for user+       ; let vis_pats = numVisibleArgs hs_pats+       ; checkTc (vis_pats == vis_arity) $+                  wrongNumberOfParmsErr vis_arity+       ; discardResult $+         bindImplicitTKBndrs_Q_Tv imp_vars $+         bindExplicitTKBndrs_Q_Tv AnyKind (mb_expl_bndrs `orElse` []) $+         do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats+            ; tcCheckLHsType hs_rhs_ty res_kind }+             -- Why "_Tv" here?  Consider (#14066+             --  type family Bar x y where+             --      Bar (x :: a) (y :: b) = Int+             --      Bar (x :: c) (y :: d) = Bool+             -- During kind-checkig, a,b,c,d should be TyVarTvs and unify appropriately+    }+  where+    vis_arity = length (tyConVisibleTyVars tc_fam_tc)++kcTyFamInstEqn _ (dL->L _ (XHsImplicitBndrs nec)) = noExtCon nec+kcTyFamInstEqn _ (dL->L _ (HsIB _ (XFamEqn nec))) = noExtCon nec+kcTyFamInstEqn _ _ = panic "kcTyFamInstEqn: Impossible Match" -- due to #15884+++--------------------------+tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn+               -> TcM (KnotTied CoAxBranch)+-- Needs to be here, not in TcInstDcls, because closed families+-- (typechecked here) have TyFamInstEqns++tcTyFamInstEqn fam_tc mb_clsinfo+    (dL->L loc (HsIB { hsib_ext = imp_vars+                 , hsib_body = FamEqn { feqn_tycon  = L _ eqn_tc_name+                                      , feqn_bndrs  = mb_expl_bndrs+                                      , feqn_pats   = hs_pats+                                      , feqn_rhs    = hs_rhs_ty }}))+  = ASSERT( getName fam_tc == eqn_tc_name )+    setSrcSpan loc $+    do {+       -- First, check the arity of visible arguments+       -- If we wait until validity checking, we'll get kind errors+       -- below when an arity error will be much easier to understand.+       ; let vis_arity = length (tyConVisibleTyVars fam_tc)+             vis_pats  = numVisibleArgs hs_pats+       ; checkTc (vis_pats == vis_arity) $+         wrongNumberOfParmsErr vis_arity+       ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo+                                      imp_vars (mb_expl_bndrs `orElse` [])+                                      hs_pats hs_rhs_ty+       -- Don't print results they may be knot-tied+       -- (tcFamInstEqnGuts zonks to Type)+       ; return (mkCoAxBranch qtvs [] [] pats rhs_ty+                              (map (const Nominal) qtvs)+                              loc) }++tcTyFamInstEqn _ _ _ = panic "tcTyFamInstEqn"++{-+Kind check type patterns and kind annotate the embedded type variables.+     type instance F [a] = rhs++ * Here we check that a type instance matches its kind signature, but we do+   not check whether there is a pattern for each type index; the latter+   check is only required for type synonym instances.++Note [Instantiating a family tycon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's possible that kind-checking the result of a family tycon applied to+its patterns will instantiate the tycon further. For example, we might+have++  type family F :: k where+    F = Int+    F = Maybe++After checking (F :: forall k. k) (with no visible patterns), we still need+to instantiate the k. With data family instances, this problem can be even+more intricate, due to Note [Arity of data families] in FamInstEnv. See+indexed-types/should_compile/T12369 for an example.++So, the kind-checker must return the new skolems and args (that is, Type+or (Type -> Type) for the equations above) and the instantiated kind.++Note [Generalising in tcTyFamInstEqnGuts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have something like+  type instance forall (a::k) b. F t1 t2 = rhs++Then  imp_vars = [k], exp_bndrs = [a::k, b]++We want to quantify over+  * k, a, and b  (all user-specified)+  * and any inferred free kind vars from+      - the kinds of k, a, b+      - the types t1, t2++However, unlike a type signature like+  f :: forall (a::k). blah++we do /not/ care about the Inferred/Specified designation+or order for the final quantified tyvars.  Type-family+instances are not invoked directly in Haskell source code,+so visible type application etc plays no role.++So, the simple thing is+   - gather candiates from [k, a, b] and pats+   - quantify over them++Hence the sligtly mysterious call:+    candidateQTyVarsOfTypes (pats ++ mkTyVarTys scoped_tvs)++Simple, neat, but a little non-obvious!+-}++--------------------------+tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo+                   -> [Name] -> [LHsTyVarBndr GhcRn]  -- Implicit and explicicit binder+                   -> HsTyPats GhcRn                  -- Patterns+                   -> LHsType GhcRn                   -- RHS+                   -> TcM ([TyVar], [TcType], TcType)      -- (tyvars, pats, rhs)+-- Used only for type families, not data families+tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty+  = do { traceTc "tcTyFamInstEqnGuts {" (vcat [ ppr fam_tc <+> ppr hs_pats ])++       -- By now, for type families (but not data families) we should+       -- have checked that the number of patterns matches tyConArity++       -- This code is closely related to the code+       -- in TcHsType.kcCheckDeclHeader_cusk+       ; (imp_tvs, (exp_tvs, (lhs_ty, rhs_ty)))+               <- pushTcLevelM_                                $+                  solveEqualities                              $+                  bindImplicitTKBndrs_Q_Skol imp_vars          $+                  bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $+                  do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats+                       -- Ensure that the instance is consistent with its+                       -- parent class (#16008)+                     ; addConsistencyConstraints mb_clsinfo lhs_ty+                     ; rhs_ty <- tcCheckLHsType hs_rhs_ty rhs_kind+                     ; return (lhs_ty, rhs_ty) }++       -- See Note [Generalising in tcTyFamInstEqnGuts]+       -- This code (and the stuff immediately above) is very similar+       -- to that in tcDataFamInstHeader.  Maybe we should abstract the+       -- common code; but for the moment I concluded that it's+       -- clearer to duplicate it.  Still, if you fix a bug here,+       -- check there too!+       ; let scoped_tvs = imp_tvs ++ exp_tvs+       ; dvs  <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs)+       ; qtvs <- quantifyTyVars dvs++       ; (ze, qtvs) <- zonkTyBndrs qtvs+       ; lhs_ty     <- zonkTcTypeToTypeX ze lhs_ty+       ; rhs_ty     <- zonkTcTypeToTypeX ze rhs_ty++       ; let pats = unravelFamInstPats lhs_ty+             -- Note that we do this after solveEqualities+             -- so that any strange coercions inside lhs_ty+             -- have been solved before we attempt to unravel it+       ; traceTc "tcTyFamInstEqnGuts }" (ppr fam_tc <+> pprTyVars qtvs)+       ; return (qtvs, pats, rhs_ty) }++-----------------+tcFamTyPats :: TyCon+            -> HsTyPats GhcRn                -- Patterns+            -> TcM (TcType, TcKind)          -- (lhs_type, lhs_kind)+-- Used for both type and data families+tcFamTyPats fam_tc hs_pats+  = do { traceTc "tcFamTyPats {" $+         vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ]++       ; let fun_ty = mkTyConApp fam_tc []++       ; (fam_app, res_kind) <- unsetWOptM Opt_WarnPartialTypeSignatures $+                                setXOptM LangExt.PartialTypeSignatures $+                                -- See Note [Wildcards in family instances] in+                                -- RnSource.hs+                                tcInferApps typeLevelMode lhs_fun fun_ty hs_pats++       ; traceTc "End tcFamTyPats }" $+         vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ]++       ; return (fam_app, res_kind) }+  where+    fam_name  = tyConName fam_tc+    fam_arity = tyConArity fam_tc+    lhs_fun   = noLoc (HsTyVar noExtField NotPromoted (noLoc fam_name))++unravelFamInstPats :: TcType -> [TcType]+-- Decompose fam_app to get the argument patterns+--+-- We expect fam_app to look like (F t1 .. tn)+-- tcInferApps is capable of returning ((F ty1 |> co) ty2),+-- but that can't happen here because we already checked the+-- arity of F matches the number of pattern+unravelFamInstPats fam_app+  = case splitTyConApp_maybe fam_app of+      Just (_, pats) -> pats+      Nothing -> panic "unravelFamInstPats: Ill-typed LHS of family instance"+        -- The Nothing case cannot happen for type families, because+        -- we don't call unravelFamInstPats until we've solved the+        -- equalities. For data families, it shouldn't happen either,+        -- we need to fail hard and early if it does. See trac issue #15905+        -- for an example of this happening.++addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM ()+-- In the corresponding positions of the class and type-family,+-- ensure the the family argument is the same as the class argument+--   E.g    class C a b c d where+--             F c x y a :: Type+-- Here the first  arg of F should be the same as the third of C+--  and the fourth arg of F should be the same as the first of C+--+-- We emit /Derived/ constraints (a bit like fundeps) to encourage+-- unification to happen, but without actually reporting errors.+-- If, despite the efforts, corresponding positions do not match,+-- checkConsistentFamInst will complain+addConsistencyConstraints mb_clsinfo fam_app+  | InClsInst { ai_inst_env = inst_env } <- mb_clsinfo+  , Just (fam_tc, pats) <- tcSplitTyConApp_maybe fam_app+  = do { let eqs = [ (cls_ty, pat)+                   | (fam_tc_tv, pat) <- tyConTyVars fam_tc `zip` pats+                   , Just cls_ty <- [lookupVarEnv inst_env fam_tc_tv] ]+       ; traceTc "addConsistencyConstraints" (ppr eqs)+       ; emitDerivedEqs AssocFamPatOrigin eqs }+    -- Improve inference+    -- Any mis-match is reports by checkConsistentFamInst+  | otherwise+  = return ()++{- Note [Constraints in patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB: This isn't the whole story. See comment in tcFamTyPats.++At first glance, it seems there is a complicated story to tell in tcFamTyPats+around constraint solving. After all, type family patterns can now do+GADT pattern-matching, which is jolly complicated. But, there's a key fact+which makes this all simple: everything is at top level! There cannot+be untouchable type variables. There can't be weird interaction between+case branches. There can't be global skolems.++This means that the semantics of type-level GADT matching is a little+different than term level. If we have++  data G a where+    MkGBool :: G Bool++And then++  type family F (a :: G k) :: k+  type instance F MkGBool = True++we get++  axF : F Bool (MkGBool <Bool>) ~ True++Simple! No casting on the RHS, because we can affect the kind parameter+to F.++If we ever introduce local type families, this all gets a lot more+complicated, and will end up looking awfully like term-level GADT+pattern-matching.+++** The new story **++Here is really what we want:++The matcher really can't deal with covars in arbitrary spots in coercions.+But it can deal with covars that are arguments to GADT data constructors.+So we somehow want to allow covars only in precisely those spots, then use+them as givens when checking the RHS. TODO (RAE): Implement plan.++Note [Quantified kind variables of a family pattern]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider   type family KindFam (p :: k1) (q :: k1)+           data T :: Maybe k1 -> k2 -> *+           type instance KindFam (a :: Maybe k) b = T a b -> Int+The HsBSig for the family patterns will be ([k], [a])++Then in the family instance we want to+  * Bring into scope [ "k" -> k:*, "a" -> a:k ]+  * Kind-check the RHS+  * Quantify the type instance over k and k', as well as a,b, thus+       type instance [k, k', a:Maybe k, b:k']+                     KindFam (Maybe k) k' a b = T k k' a b -> Int++Notice that in the third step we quantify over all the visibly-mentioned+type variables (a,b), but also over the implicitly mentioned kind variables+(k, k').  In this case one is bound explicitly but often there will be+none. The role of the kind signature (a :: Maybe k) is to add a constraint+that 'a' must have that kind, and to bring 'k' into scope.++++************************************************************************+*                                                                      *+               Data types+*                                                                      *+************************************************************************+-}++dataDeclChecks :: Name -> NewOrData+               -> LHsContext GhcRn -> [LConDecl GhcRn]+               -> TcM Bool+dataDeclChecks tc_name new_or_data (L _ stupid_theta) cons+  = do {   -- Check that we don't use GADT syntax in H98 world+         gadtSyntax_ok <- xoptM LangExt.GADTSyntax+       ; let gadt_syntax = consUseGadtSyntax cons+       ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name)++           -- Check that the stupid theta is empty for a GADT-style declaration+       ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name)++         -- Check that a newtype has exactly one constructor+         -- Do this before checking for empty data decls, so that+         -- we don't suggest -XEmptyDataDecls for newtypes+       ; checkTc (new_or_data == DataType || isSingleton cons)+                (newtypeConError tc_name (length cons))++         -- Check that there's at least one condecl,+         -- or else we're reading an hs-boot file, or -XEmptyDataDecls+       ; empty_data_decls <- xoptM LangExt.EmptyDataDecls+       ; is_boot <- tcIsHsBootOrSig  -- Are we compiling an hs-boot file?+       ; checkTc (not (null cons) || empty_data_decls || is_boot)+                 (emptyConDeclsErr tc_name)+       ; return gadt_syntax }+++-----------------------------------+consUseGadtSyntax :: [LConDecl a] -> Bool+consUseGadtSyntax ((dL->L _ (ConDeclGADT {})) : _) = True+consUseGadtSyntax _                                = False+                 -- All constructors have same shape++-----------------------------------+tcConDecls :: KnotTied TyCon -> NewOrData+           -> [TyConBinder] -> TcKind   -- binders and result kind of tycon+           -> KnotTied Type -> [LConDecl GhcRn] -> TcM [DataCon]+tcConDecls rep_tycon new_or_data tmpl_bndrs res_kind res_tmpl+  = concatMapM $ addLocM $+    tcConDecl rep_tycon (mkTyConTagMap rep_tycon)+              tmpl_bndrs res_kind res_tmpl new_or_data+    -- It's important that we pay for tag allocation here, once per TyCon,+    -- See Note [Constructor tag allocation], fixes #14657++tcConDecl :: KnotTied TyCon          -- Representation tycon. Knot-tied!+          -> NameEnv ConTag+          -> [TyConBinder] -> TcKind   -- tycon binders and result kind+          -> KnotTied Type+                 -- Return type template (T tys), where T is the family TyCon+          -> NewOrData+          -> ConDecl GhcRn+          -> TcM [DataCon]++tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data+          (ConDeclH98 { con_name = name+                      , con_ex_tvs = explicit_tkv_nms+                      , con_mb_cxt = hs_ctxt+                      , con_args = hs_args })+  = addErrCtxt (dataConCtxtName [name]) $+    do { -- NB: the tyvars from the declaration header are in scope++         -- Get hold of the existential type variables+         -- e.g. data T a = forall k (b::k) f. MkT a (f b)+         -- Here tmpl_bndrs = {a}+         --      hs_qvars = HsQTvs { hsq_implicit = {k}+         --                        , hsq_explicit = {f,b} }++       ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ])++       ; (exp_tvs, (ctxt, arg_tys, field_lbls, stricts))+           <- pushTcLevelM_                             $+              solveEqualities                           $+              bindExplicitTKBndrs_Skol explicit_tkv_nms $+              do { ctxt <- tcHsMbContext hs_ctxt+                 ; btys <- tcConArgs hs_args+                 ; field_lbls <- lookupConstructorFields (unLoc name)+                 ; let (arg_tys, stricts) = unzip btys+                 ; dflags <- getDynFlags+                 ; final_arg_tys <-+                     unifyNewtypeKind dflags new_or_data+                                      (hsConDeclArgTys hs_args)+                                      arg_tys res_kind+                 ; return (ctxt, final_arg_tys, field_lbls, stricts)+                 }++         -- exp_tvs have explicit, user-written binding sites+         -- the kvs below are those kind variables entirely unmentioned by the user+         --   and discovered only by generalization++       ; kvs <- kindGeneralizeAll (mkSpecForAllTys (binderVars tmpl_bndrs) $+                                   mkSpecForAllTys exp_tvs $+                                   mkPhiTy ctxt $+                                   mkVisFunTys arg_tys $+                                   unitTy)+                 -- That type is a lie, of course. (It shouldn't end in ()!)+                 -- And we could construct a proper result type from the info+                 -- at hand. But the result would mention only the tmpl_tvs,+                 -- and so it just creates more work to do it right. Really,+                 -- we're only doing this to find the right kind variables to+                 -- quantify over, and this type is fine for that purpose.++             -- Zonk to Types+       ; (ze, qkvs)      <- zonkTyBndrs kvs+       ; (ze, user_qtvs) <- zonkTyBndrsX ze exp_tvs+       ; arg_tys         <- zonkTcTypesToTypesX ze arg_tys+       ; ctxt            <- zonkTcTypesToTypesX ze ctxt++       ; fam_envs <- tcGetFamInstEnvs++       -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here+       ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls)+       ; let+           univ_tvbs = tyConTyVarBinders tmpl_bndrs+           univ_tvs  = binderVars univ_tvbs+           ex_tvbs   = mkTyVarBinders Inferred qkvs +++                       mkTyVarBinders Specified user_qtvs+           ex_tvs    = qkvs ++ user_qtvs+           -- For H98 datatypes, the user-written tyvar binders are precisely+           -- the universals followed by the existentials.+           -- See Note [DataCon user type variable binders] in DataCon.+           user_tvbs = univ_tvbs ++ ex_tvbs+           buildOneDataCon (dL->L _ name) = do+             { is_infix <- tcConIsInfixH98 name hs_args+             ; rep_nm   <- newTyConRepName name++             ; buildDataCon fam_envs name is_infix rep_nm+                            stricts Nothing field_lbls+                            univ_tvs ex_tvs user_tvbs+                            [{- no eq_preds -}] ctxt arg_tys+                            res_tmpl rep_tycon tag_map+                  -- NB:  we put data_tc, the type constructor gotten from the+                  --      constructor type signature into the data constructor;+                  --      that way checkValidDataCon can complain if it's wrong.+             }+       ; traceTc "tcConDecl 2" (ppr name)+       ; mapM buildOneDataCon [name]+       }++tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data+  -- NB: don't use res_kind here, as it's ill-scoped. Instead, we get+  -- the res_kind by typechecking the result type.+          (ConDeclGADT { con_names = names+                       , con_qvars = qtvs+                       , con_mb_cxt = cxt, con_args = hs_args+                       , con_res_ty = hs_res_ty })+  | HsQTvs { hsq_ext = implicit_tkv_nms+           , hsq_explicit = explicit_tkv_nms } <- qtvs+  = addErrCtxt (dataConCtxtName names) $+    do { traceTc "tcConDecl 1 gadt" (ppr names)+       ; let ((dL->L _ name) : _) = names++       ; (imp_tvs, (exp_tvs, (ctxt, arg_tys, res_ty, field_lbls, stricts)))+           <- pushTcLevelM_    $  -- We are going to generalise+              solveEqualities  $  -- We won't get another crack, and we don't+                                  -- want an error cascade+              bindImplicitTKBndrs_Skol implicit_tkv_nms $+              bindExplicitTKBndrs_Skol explicit_tkv_nms $+              do { ctxt <- tcHsMbContext cxt+                 ; btys <- tcConArgs hs_args+                 ; let (arg_tys, stricts) = unzip btys+                 ; res_ty <- tcHsOpenType hs_res_ty+                   -- See Note [Implementation of UnliftedNewtypes]+                 ; dflags <- getDynFlags+                 ; final_arg_tys <-+                     unifyNewtypeKind dflags new_or_data+                                      (hsConDeclArgTys hs_args)+                                      arg_tys (typeKind res_ty)+                 ; field_lbls <- lookupConstructorFields name+                 ; return (ctxt, final_arg_tys, res_ty, field_lbls, stricts)+                 }+       ; imp_tvs <- zonkAndScopedSort imp_tvs+       ; let user_tvs      = imp_tvs ++ exp_tvs++       ; tkvs <- kindGeneralizeAll (mkSpecForAllTys user_tvs $+                                    mkPhiTy ctxt $+                                    mkVisFunTys arg_tys $+                                    res_ty)++             -- Zonk to Types+       ; (ze, tkvs)     <- zonkTyBndrs tkvs+       ; (ze, user_tvs) <- zonkTyBndrsX ze user_tvs+       ; arg_tys <- zonkTcTypesToTypesX ze arg_tys+       ; ctxt    <- zonkTcTypesToTypesX ze ctxt+       ; res_ty  <- zonkTcTypeToTypeX   ze res_ty++       ; let (univ_tvs, ex_tvs, tkvs', user_tvs', eq_preds, arg_subst)+               = rejigConRes tmpl_bndrs res_tmpl tkvs user_tvs res_ty+             -- NB: this is a /lazy/ binding, so we pass six thunks to+             --     buildDataCon without yet forcing the guards in rejigConRes+             -- See Note [Checking GADT return types]++             -- Compute the user-written tyvar binders. These have the same+             -- tyvars as univ_tvs/ex_tvs, but perhaps in a different order.+             -- See Note [DataCon user type variable binders] in DataCon.+             tkv_bndrs      = mkTyVarBinders Inferred  tkvs'+             user_tv_bndrs  = mkTyVarBinders Specified user_tvs'+             all_user_bndrs = tkv_bndrs ++ user_tv_bndrs++             ctxt'      = substTys arg_subst ctxt+             arg_tys'   = substTys arg_subst arg_tys+             res_ty'    = substTy  arg_subst res_ty+++       ; fam_envs <- tcGetFamInstEnvs++       -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here+       ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls)+       ; let+           buildOneDataCon (dL->L _ name) = do+             { is_infix <- tcConIsInfixGADT name hs_args+             ; rep_nm   <- newTyConRepName name++             ; buildDataCon fam_envs name is_infix+                            rep_nm+                            stricts Nothing field_lbls+                            univ_tvs ex_tvs all_user_bndrs eq_preds+                            ctxt' arg_tys' res_ty' rep_tycon tag_map+                  -- NB:  we put data_tc, the type constructor gotten from the+                  --      constructor type signature into the data constructor;+                  --      that way checkValidDataCon can complain if it's wrong.+             }+       ; traceTc "tcConDecl 2" (ppr names)+       ; mapM buildOneDataCon names+       }+tcConDecl _ _ _ _ _ _ (ConDeclGADT _ _ _ (XLHsQTyVars nec) _ _ _ _)+  = noExtCon nec+tcConDecl _ _ _ _ _ _ (XConDecl nec) = noExtCon nec++tcConIsInfixH98 :: Name+             -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])+             -> TcM Bool+tcConIsInfixH98 _   details+  = case details of+           InfixCon {}  -> return True+           _            -> return False++tcConIsInfixGADT :: Name+             -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])+             -> TcM Bool+tcConIsInfixGADT con details+  = case details of+           InfixCon {}  -> return True+           RecCon {}    -> return False+           PrefixCon arg_tys           -- See Note [Infix GADT constructors]+               | isSymOcc (getOccName con)+               , [_ty1,_ty2] <- arg_tys+                  -> do { fix_env <- getFixityEnv+                        ; return (con `elemNameEnv` fix_env) }+               | otherwise -> return False++tcConArgs :: HsConDeclDetails GhcRn+          -> TcM [(TcType, HsSrcBang)]+tcConArgs (PrefixCon btys)+  = mapM tcConArg btys+tcConArgs (InfixCon bty1 bty2)+  = do { bty1' <- tcConArg bty1+       ; bty2' <- tcConArg bty2+       ; return [bty1', bty2'] }+tcConArgs (RecCon fields)+  = mapM tcConArg btys+  where+    -- We need a one-to-one mapping from field_names to btys+    combined = map (\(dL->L _ f) -> (cd_fld_names f,cd_fld_type f))+                   (unLoc fields)+    explode (ns,ty) = zip ns (repeat ty)+    exploded = concatMap explode combined+    (_,btys) = unzip exploded+++tcConArg :: LHsType GhcRn -> TcM (TcType, HsSrcBang)+tcConArg bty+  = do  { traceTc "tcConArg 1" (ppr bty)+        ; arg_ty <- tcHsOpenType (getBangType bty)+             -- Newtypes can't have unboxed types, but we check+             -- that in checkValidDataCon; this tcConArg stuff+             -- doesn't happen for GADT-style declarations+        ; traceTc "tcConArg 2" (ppr bty)+        ; return (arg_ty, getBangStrictness bty) }++{-+Note [Infix GADT constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not currently have syntax to declare an infix constructor in GADT syntax,+but it makes a (small) difference to the Show instance.  So as a slightly+ad-hoc solution, we regard a GADT data constructor as infix if+  a) it is an operator symbol+  b) it has two arguments+  c) there is a fixity declaration for it+For example:+   infix 6 (:--:)+   data T a where+     (:--:) :: t1 -> t2 -> T Int+++Note [Checking GADT return types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is a delicacy around checking the return types of a datacon. The+central problem is dealing with a declaration like++  data T a where+    MkT :: T a -> Q a++Note that the return type of MkT is totally bogus. When creating the T+tycon, we also need to create the MkT datacon, which must have a "rejigged"+return type. That is, the MkT datacon's type must be transformed to have+a uniform return type with explicit coercions for GADT-like type parameters.+This rejigging is what rejigConRes does. The problem is, though, that checking+that the return type is appropriate is much easier when done over *Type*,+not *HsType*, and doing a call to tcMatchTy will loop because T isn't fully+defined yet.++So, we want to make rejigConRes lazy and then check the validity of+the return type in checkValidDataCon.  To do this we /always/ return a+6-tuple from rejigConRes (so that we can compute the return type from it, which+checkValidDataCon needs), but the first three fields may be bogus if+the return type isn't valid (the last equation for rejigConRes).++This is better than an earlier solution which reduced the number of+errors reported in one pass.  See #7175, and #10836.+-}++-- Example+--   data instance T (b,c) where+--      TI :: forall e. e -> T (e,e)+--+-- The representation tycon looks like this:+--   data :R7T b c where+--      TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1+-- In this case orig_res_ty = T (e,e)++rejigConRes :: [KnotTied TyConBinder] -> KnotTied Type    -- Template for result type; e.g.+                                  -- data instance T [a] b c ...+                                  --      gives template ([a,b,c], T [a] b c)+            -> [TyVar]            -- The constructor's inferred type variables+            -> [TyVar]            -- The constructor's user-written, specified+                                  -- type variables+            -> KnotTied Type      -- res_ty+            -> ([TyVar],          -- Universal+                [TyVar],          -- Existential (distinct OccNames from univs)+                [TyVar],          -- The constructor's rejigged, user-written,+                                  -- inferred type variables+                [TyVar],          -- The constructor's rejigged, user-written,+                                  -- specified type variables+                [EqSpec],      -- Equality predicates+                TCvSubst)      -- Substitution to apply to argument types+        -- We don't check that the TyCon given in the ResTy is+        -- the same as the parent tycon, because checkValidDataCon will do it+-- NB: All arguments may potentially be knot-tied+rejigConRes tmpl_bndrs res_tmpl dc_inferred_tvs dc_specified_tvs res_ty+        -- E.g.  data T [a] b c where+        --         MkT :: forall x y z. T [(x,y)] z z+        -- The {a,b,c} are the tmpl_tvs, and the {x,y,z} are the dc_tvs+        --     (NB: unlike the H98 case, the dc_tvs are not all existential)+        -- Then we generate+        --      Univ tyvars     Eq-spec+        --          a              a~(x,y)+        --          b              b~z+        --          z+        -- Existentials are the leftover type vars: [x,y]+        -- The user-written type variables are what is listed in the forall:+        --   [x, y, z] (all specified). We must rejig these as well.+        --   See Note [DataCon user type variable binders] in DataCon.+        -- So we return ( [a,b,z], [x,y]+        --              , [], [x,y,z]+        --              , [a~(x,y),b~z], <arg-subst> )+  | Just subst <- tcMatchTy res_tmpl res_ty+  = let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tmpl_tvs dc_tvs subst+        raw_ex_tvs = dc_tvs `minusList` univ_tvs+        (arg_subst, substed_ex_tvs) = substTyVarBndrs kind_subst raw_ex_tvs++        -- After rejigging the existential tyvars, the resulting substitution+        -- gives us exactly what we need to rejig the user-written tyvars,+        -- since the dcUserTyVarBinders invariant guarantees that the+        -- substitution has *all* the tyvars in its domain.+        -- See Note [DataCon user type variable binders] in DataCon.+        subst_user_tvs = map (getTyVar "rejigConRes" . substTyVar arg_subst)+        substed_inferred_tvs  = subst_user_tvs dc_inferred_tvs+        substed_specified_tvs = subst_user_tvs dc_specified_tvs++        substed_eqs = map (substEqSpec arg_subst) raw_eqs+    in+    (univ_tvs, substed_ex_tvs, substed_inferred_tvs, substed_specified_tvs,+     substed_eqs, arg_subst)++  | otherwise+        -- If the return type of the data constructor doesn't match the parent+        -- type constructor, or the arity is wrong, the tcMatchTy will fail+        --    e.g   data T a b where+        --            T1 :: Maybe a   -- Wrong tycon+        --            T2 :: T [a]     -- Wrong arity+        -- We are detect that later, in checkValidDataCon, but meanwhile+        -- we must do *something*, not just crash.  So we do something simple+        -- albeit bogus, relying on checkValidDataCon to check the+        --  bad-result-type error before seeing that the other fields look odd+        -- See Note [Checking GADT return types]+  = (tmpl_tvs, dc_tvs `minusList` tmpl_tvs, dc_inferred_tvs, dc_specified_tvs,+     [], emptyTCvSubst)+  where+    dc_tvs   = dc_inferred_tvs ++ dc_specified_tvs+    tmpl_tvs = binderVars tmpl_bndrs++{- Note [mkGADTVars]+~~~~~~~~~~~~~~~~~~~~+Running example:++data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where+  MkT :: forall (x1 : *) (y :: x1) (z :: *).+         T x1 * (Proxy (y :: x1), z) z++We need the rejigged type to be++  MkT :: forall (x1 :: *) (k2 :: *) (a :: k2) (b :: k2).+         forall (y :: x1) (z :: *).+         (k2 ~ *, a ~ (Proxy x1 y, z), b ~ z)+      => T x1 k2 a b++You might naively expect that z should become a universal tyvar,+not an existential. (After all, x1 becomes a universal tyvar.)+But z has kind * while b has kind k2, so the return type+   T x1 k2 a z+is ill-kinded.  Another way to say it is this: the universal+tyvars must have exactly the same kinds as the tyConTyVars.++So we need an existential tyvar and a heterogeneous equality+constraint. (The b ~ z is a bit redundant with the k2 ~ * that+comes before in that b ~ z implies k2 ~ *. I'm sure we could do+some analysis that could eliminate k2 ~ *. But we don't do this+yet.)++The data con signature has already been fully kind-checked.+The return type++  T x1 * (Proxy (y :: x1), z) z+becomes+  qtkvs    = [x1 :: *, y :: x1, z :: *]+  res_tmpl = T x1 * (Proxy x1 y, z) z++We start off by matching (T k1 k2 a b) with (T x1 * (Proxy x1 y, z) z). We+know this match will succeed because of the validity check (actually done+later, but laziness saves us -- see Note [Checking GADT return types]).+Thus, we get++  subst := { k1 |-> x1, k2 |-> *, a |-> (Proxy x1 y, z), b |-> z }++Now, we need to figure out what the GADT equalities should be. In this case,+we *don't* want (k1 ~ x1) to be a GADT equality: it should just be a+renaming. The others should be GADT equalities. We also need to make+sure that the universally-quantified variables of the datacon match up+with the tyvars of the tycon, as required for Core context well-formedness.+(This last bit is why we have to rejig at all!)++`choose` walks down the tycon tyvars, figuring out what to do with each one.+It carries two substitutions:+  - t_sub's domain is *template* or *tycon* tyvars, mapping them to variables+    mentioned in the datacon signature.+  - r_sub's domain is *result* tyvars, names written by the programmer in+    the datacon signature. The final rejigged type will use these names, but+    the subst is still needed because sometimes the printed name of these variables+    is different. (See choose_tv_name, below.)++Before explaining the details of `choose`, let's just look at its operation+on our example:++  choose [] [] {} {} [k1, k2, a, b]+  -->          -- first branch of `case` statement+  choose+    univs:    [x1 :: *]+    eq_spec:  []+    t_sub:    {k1 |-> x1}+    r_sub:    {x1 |-> x1}+    t_tvs:    [k2, a, b]+  -->          -- second branch of `case` statement+  choose+    univs:    [k2 :: *, x1 :: *]+    eq_spec:  [k2 ~ *]+    t_sub:    {k1 |-> x1, k2 |-> k2}+    r_sub:    {x1 |-> x1}+    t_tvs:    [a, b]+  -->          -- second branch of `case` statement+  choose+    univs:    [a :: k2, k2 :: *, x1 :: *]+    eq_spec:  [ a ~ (Proxy x1 y, z)+              , k2 ~ * ]+    t_sub:    {k1 |-> x1, k2 |-> k2, a |-> a}+    r_sub:    {x1 |-> x1}+    t_tvs:    [b]+  -->          -- second branch of `case` statement+  choose+    univs:    [b :: k2, a :: k2, k2 :: *, x1 :: *]+    eq_spec:  [ b ~ z+              , a ~ (Proxy x1 y, z)+              , k2 ~ * ]+    t_sub:    {k1 |-> x1, k2 |-> k2, a |-> a, b |-> z}+    r_sub:    {x1 |-> x1}+    t_tvs:    []+  -->          -- end of recursion+  ( [x1 :: *, k2 :: *, a :: k2, b :: k2]+  , [k2 ~ *, a ~ (Proxy x1 y, z), b ~ z]+  , {x1 |-> x1} )++`choose` looks up each tycon tyvar in the matching (it *must* be matched!).++* If it finds a bare result tyvar (the first branch of the `case`+  statement), it checks to make sure that the result tyvar isn't yet+  in the list of univ_tvs.  If it is in that list, then we have a+  repeated variable in the return type, and we in fact need a GADT+  equality.++* It then checks to make sure that the kind of the result tyvar+  matches the kind of the template tyvar. This check is what forces+  `z` to be existential, as it should be, explained above.++* Assuming no repeated variables or kind-changing, we wish to use the+  variable name given in the datacon signature (that is, `x1` not+  `k1`), not the tycon signature (which may have been made up by+  GHC). So, we add a mapping from the tycon tyvar to the result tyvar+  to t_sub.++* If we discover that a mapping in `subst` gives us a non-tyvar (the+  second branch of the `case` statement), then we have a GADT equality+  to create.  We create a fresh equality, but we don't extend any+  substitutions. The template variable substitution is meant for use+  in universal tyvar kinds, and these shouldn't be affected by any+  GADT equalities.++This whole algorithm is quite delicate, indeed. I (Richard E.) see two ways+of simplifying it:++1) The first branch of the `case` statement is really an optimization, used+in order to get fewer GADT equalities. It might be possible to make a GADT+equality for *every* univ. tyvar, even if the equality is trivial, and then+either deal with the bigger type or somehow reduce it later.++2) This algorithm strives to use the names for type variables as specified+by the user in the datacon signature. If we always used the tycon tyvar+names, for example, this would be simplified. This change would almost+certainly degrade error messages a bit, though.+-}++-- ^ From information about a source datacon definition, extract out+-- what the universal variables and the GADT equalities should be.+-- See Note [mkGADTVars].+mkGADTVars :: [TyVar]    -- ^ The tycon vars+           -> [TyVar]    -- ^ The datacon vars+           -> TCvSubst   -- ^ The matching between the template result type+                         -- and the actual result type+           -> ( [TyVar]+              , [EqSpec]+              , TCvSubst ) -- ^ The univ. variables, the GADT equalities,+                           -- and a subst to apply to the GADT equalities+                           -- and existentials.+mkGADTVars tmpl_tvs dc_tvs subst+  = choose [] [] empty_subst empty_subst tmpl_tvs+  where+    in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs)+               `unionInScope` getTCvInScope subst+    empty_subst = mkEmptyTCvSubst in_scope++    choose :: [TyVar]           -- accumulator of univ tvs, reversed+           -> [EqSpec]          -- accumulator of GADT equalities, reversed+           -> TCvSubst          -- template substitution+           -> TCvSubst          -- res. substitution+           -> [TyVar]           -- template tvs (the univ tvs passed in)+           -> ( [TyVar]         -- the univ_tvs+              , [EqSpec]        -- GADT equalities+              , TCvSubst )       -- a substitution to fix kinds in ex_tvs++    choose univs eqs _t_sub r_sub []+      = (reverse univs, reverse eqs, r_sub)+    choose univs eqs t_sub r_sub (t_tv:t_tvs)+      | Just r_ty <- lookupTyVar subst t_tv+      = case getTyVar_maybe r_ty of+          Just r_tv+            |  not (r_tv `elem` univs)+            ,  tyVarKind r_tv `eqType` (substTy t_sub (tyVarKind t_tv))+            -> -- simple, well-kinded variable substitution.+               choose (r_tv:univs) eqs+                      (extendTvSubst t_sub t_tv r_ty')+                      (extendTvSubst r_sub r_tv r_ty')+                      t_tvs+            where+              r_tv1  = setTyVarName r_tv (choose_tv_name r_tv t_tv)+              r_ty'  = mkTyVarTy r_tv1++               -- Not a simple substitution: make an equality predicate+          _ -> choose (t_tv':univs) (mkEqSpec t_tv' r_ty : eqs)+                      (extendTvSubst t_sub t_tv (mkTyVarTy t_tv'))+                         -- We've updated the kind of t_tv,+                         -- so add it to t_sub (#14162)+                      r_sub t_tvs+            where+              t_tv' = updateTyVarKind (substTy t_sub) t_tv++      | otherwise+      = pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst)++      -- choose an appropriate name for a univ tyvar.+      -- This *must* preserve the Unique of the result tv, so that we+      -- can detect repeated variables. It prefers user-specified names+      -- over system names. A result variable with a system name can+      -- happen with GHC-generated implicit kind variables.+    choose_tv_name :: TyVar -> TyVar -> Name+    choose_tv_name r_tv t_tv+      | isSystemName r_tv_name+      = setNameUnique t_tv_name (getUnique r_tv_name)++      | otherwise+      = r_tv_name++      where+        r_tv_name = getName r_tv+        t_tv_name = getName t_tv++{-+Note [Substitution in template variables kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++data G (a :: Maybe k) where+  MkG :: G Nothing++With explicit kind variables++data G k (a :: Maybe k) where+  MkG :: G k1 (Nothing k1)++Note how k1 is distinct from k. So, when we match the template+`G k a` against `G k1 (Nothing k1)`, we get a subst+[ k |-> k1, a |-> Nothing k1 ]. Even though this subst has two+mappings, we surely don't want to add (k, k1) to the list of+GADT equalities -- that would be overly complex and would create+more untouchable variables than we need. So, when figuring out+which tyvars are GADT-like and which aren't (the fundamental+job of `choose`), we want to treat `k` as *not* GADT-like.+Instead, we wish to substitute in `a`'s kind, to get (a :: Maybe k1)+instead of (a :: Maybe k). This is the reason for dealing+with a substitution in here.++However, we do not *always* want to substitute. Consider++data H (a :: k) where+  MkH :: H Int++With explicit kind variables:++data H k (a :: k) where+  MkH :: H * Int++Here, we have a kind-indexed GADT. The subst in question is+[ k |-> *, a |-> Int ]. Now, we *don't* want to substitute in `a`'s+kind, because that would give a constructor with the type++MkH :: forall (k :: *) (a :: *). (k ~ *) -> (a ~ Int) -> H k a++The problem here is that a's kind is wrong -- it needs to be k, not *!+So, if the matching for a variable is anything but another bare variable,+we drop the mapping from the substitution before proceeding. This+was not an issue before kind-indexed GADTs because this case could+never happen.++************************************************************************+*                                                                      *+                Validity checking+*                                                                      *+************************************************************************++Validity checking is done once the mutually-recursive knot has been+tied, so we can look at things freely.+-}++checkValidTyCl :: TyCon -> TcM [TyCon]+-- The returned list is either a singleton (if valid)+-- or a list of "fake tycons" (if not); the fake tycons+-- include any implicits, like promoted data constructors+-- See Note [Recover from validity error]+checkValidTyCl tc+  = setSrcSpan (getSrcSpan tc) $+    addTyConCtxt tc            $+    recoverM recovery_code     $+    do { traceTc "Starting validity for tycon" (ppr tc)+       ; checkValidTyCon tc+       ; traceTc "Done validity for tycon" (ppr tc)+       ; return [tc] }+  where+    recovery_code -- See Note [Recover from validity error]+      = do { traceTc "Aborted validity for tycon" (ppr tc)+           ; return (concatMap mk_fake_tc $+                     ATyCon tc : implicitTyConThings tc) }++    mk_fake_tc (ATyCon tc)+      | isClassTyCon tc = [tc]   -- Ugh! Note [Recover from validity error]+      | otherwise       = [makeRecoveryTyCon tc]+    mk_fake_tc (AConLike (RealDataCon dc))+                        = [makeRecoveryTyCon (promoteDataCon dc)]+    mk_fake_tc _        = []++{- Note [Recover from validity error]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We recover from a validity error in a type or class, which allows us+to report multiple validity errors. In the failure case we return a+TyCon of the right kind, but with no interesting behaviour+(makeRecoveryTyCon). Why?  Suppose we have+   type T a = Fun+where Fun is a type family of arity 1.  The RHS is invalid, but we+want to go on checking validity of subsequent type declarations.+So we replace T with an abstract TyCon which will do no harm.+See indexed-types/should_fail/BadSock and #10896++Some notes:++* We must make fakes for promoted DataCons too. Consider (#15215)+      data T a = MkT ...+      data S a = ...T...MkT....+  If there is an error in the definition of 'T' we add a "fake type+  constructor" to the type environment, so that we can continue to+  typecheck 'S'.  But we /were not/ adding a fake anything for 'MkT'+  and so there was an internal error when we met 'MkT' in the body of+  'S'.++* Painfully, we *don't* want to do this for classes.+  Consider tcfail041:+     class (?x::Int) => C a where ...+     instance C Int+  The class is invalid because of the superclass constraint.  But+  we still want it to look like a /class/, else the instance bleats+  that the instance is mal-formed because it hasn't got a class in+  the head.++  This is really bogus; now we have in scope a Class that is invalid+  in some way, with unknown downstream consequences.  A better+  alterantive might be to make a fake class TyCon.  A job for another day.+-}++-------------------------+-- For data types declared with record syntax, we require+-- that each constructor that has a field 'f'+--      (a) has the same result type+--      (b) has the same type for 'f'+-- module alpha conversion of the quantified type variables+-- of the constructor.+--+-- Note that we allow existentials to match because the+-- fields can never meet. E.g+--      data T where+--        T1 { f1 :: b, f2 :: a, f3 ::Int } :: T+--        T2 { f1 :: c, f2 :: c, f3 ::Int } :: T+-- Here we do not complain about f1,f2 because they are existential++checkValidTyCon :: TyCon -> TcM ()+checkValidTyCon tc+  | isPrimTyCon tc   -- Happens when Haddock'ing GHC.Prim+  = return ()++  | otherwise+  = do { traceTc "checkValidTyCon" (ppr tc $$ ppr (tyConClass_maybe tc))+       ; if | Just cl <- tyConClass_maybe tc+              -> checkValidClass cl++            | Just syn_rhs <- synTyConRhs_maybe tc+              -> do { checkValidType syn_ctxt syn_rhs+                    ; checkTySynRhs syn_ctxt syn_rhs }++            | Just fam_flav <- famTyConFlav_maybe tc+              -> case fam_flav of+               { ClosedSynFamilyTyCon (Just ax)+                   -> tcAddClosedTypeFamilyDeclCtxt tc $+                      checkValidCoAxiom ax+               ; ClosedSynFamilyTyCon Nothing   -> return ()+               ; AbstractClosedSynFamilyTyCon ->+                 do { hsBoot <- tcIsHsBootOrSig+                    ; checkTc hsBoot $+                      text "You may define an abstract closed type family" $$+                      text "only in a .hs-boot file" }+               ; DataFamilyTyCon {}           -> return ()+               ; OpenSynFamilyTyCon           -> return ()+               ; BuiltInSynFamTyCon _         -> return () }++             | otherwise -> do+               { -- Check the context on the data decl+                 traceTc "cvtc1" (ppr tc)+               ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)++               ; traceTc "cvtc2" (ppr tc)++               ; dflags          <- getDynFlags+               ; existential_ok  <- xoptM LangExt.ExistentialQuantification+               ; gadt_ok         <- xoptM LangExt.GADTs+               ; let ex_ok = existential_ok || gadt_ok+                     -- Data cons can have existential context+               ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons+               ; mapM_ (checkPartialRecordField data_cons) (tyConFieldLabels tc)++                -- Check that fields with the same name share a type+               ; mapM_ check_fields groups }}+  where+    syn_ctxt  = TySynCtxt name+    name      = tyConName tc+    data_cons = tyConDataCons tc++    groups = equivClasses cmp_fld (concatMap get_fields data_cons)+    cmp_fld (f1,_) (f2,_) = flLabel f1 `compare` flLabel f2+    get_fields con = dataConFieldLabels con `zip` repeat con+        -- dataConFieldLabels may return the empty list, which is fine++    -- See Note [GADT record selectors] in TcTyDecls+    -- We must check (a) that the named field has the same+    --                   type in each constructor+    --               (b) that those constructors have the same result type+    --+    -- However, the constructors may have differently named type variable+    -- and (worse) we don't know how the correspond to each other.  E.g.+    --     C1 :: forall a b. { f :: a, g :: b } -> T a b+    --     C2 :: forall d c. { f :: c, g :: c } -> T c d+    --+    -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's+    -- result type against other candidates' types BOTH WAYS ROUND.+    -- If they magically agrees, take the substitution and+    -- apply them to the latter ones, and see if they match perfectly.+    check_fields ((label, con1) :| other_fields)+        -- These fields all have the same name, but are from+        -- different constructors in the data type+        = recoverM (return ()) $ mapM_ checkOne other_fields+                -- Check that all the fields in the group have the same type+                -- NB: this check assumes that all the constructors of a given+                -- data type use the same type variables+        where+        (_, _, _, res1) = dataConSig con1+        fty1 = dataConFieldType con1 lbl+        lbl = flLabel label++        checkOne (_, con2)    -- Do it both ways to ensure they are structurally identical+            = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2+                 ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 }+            where+                (_, _, _, res2) = dataConSig con2+                fty2 = dataConFieldType con2 lbl++checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM ()+-- Checks the partial record field selector, and warns.+-- See Note [Checking partial record field]+checkPartialRecordField all_cons fld+  = setSrcSpan loc $+      warnIfFlag Opt_WarnPartialFields+        (not is_exhaustive && not (startsWithUnderscore occ_name))+        (sep [text "Use of partial record field selector" <> colon,+              nest 2 $ quotes (ppr occ_name)])+  where+    sel_name = flSelector fld+    loc    = getSrcSpan sel_name+    occ_name = getOccName sel_name++    (cons_with_field, cons_without_field) = partition has_field all_cons+    has_field con = fld `elem` (dataConFieldLabels con)+    is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field++    con1 = ASSERT( not (null cons_with_field) ) head cons_with_field+    (univ_tvs, _, eq_spec, _, _, _) = dataConFullSig con1+    eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec)+    inst_tys = substTyVars eq_subst univ_tvs++checkFieldCompat :: FieldLabelString -> DataCon -> DataCon+                 -> Type -> Type -> Type -> Type -> TcM ()+checkFieldCompat fld con1 con2 res1 res2 fty1 fty2+  = do  { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2)+        ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) }+  where+    mb_subst1 = tcMatchTy res1 res2+    mb_subst2 = tcMatchTyX (expectJust "checkFieldCompat" mb_subst1) fty1 fty2++-------------------------------+checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM ()+checkValidDataCon dflags existential_ok tc con+  = setSrcSpan (getSrcSpan con)  $+    addErrCtxt (dataConCtxt con) $+    do  { -- Check that the return type of the data constructor+          -- matches the type constructor; eg reject this:+          --   data T a where { MkT :: Bogus a }+          -- It's important to do this first:+          --  see Note [Checking GADT return types]+          --  and c.f. Note [Check role annotations in a second pass]+          let tc_tvs      = tyConTyVars tc+              res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)+              orig_res_ty = dataConOrigResTy con+        ; traceTc "checkValidDataCon" (vcat+              [ ppr con, ppr tc, ppr tc_tvs+              , ppr res_ty_tmpl <+> dcolon <+> ppr (tcTypeKind res_ty_tmpl)+              , ppr orig_res_ty <+> dcolon <+> ppr (tcTypeKind orig_res_ty)])+++        ; checkTc (isJust (tcMatchTy res_ty_tmpl orig_res_ty))+                  (badDataConTyCon con res_ty_tmpl)+            -- Note that checkTc aborts if it finds an error. This is+            -- critical to avoid panicking when we call dataConUserType+            -- on an un-rejiggable datacon!++        ; traceTc "checkValidDataCon 2" (ppr (dataConUserType con))++          -- Check that the result type is a *monotype*+          --  e.g. reject this:   MkT :: T (forall a. a->a)+          -- Reason: it's really the argument of an equality constraint+        ; checkValidMonoType orig_res_ty++          -- Check all argument types for validity+        ; checkValidType ctxt (dataConUserType con)++          -- If we are dealing with a newtype, we allow levity polymorphism+          -- regardless of whether or not UnliftedNewtypes is enabled. A+          -- later check in checkNewDataCon handles this, producing a+          -- better error message than checkForLevPoly would.+        ; unless (isNewTyCon tc)+            (mapM_ (checkForLevPoly empty) (dataConOrigArgTys con))++          -- Extra checks for newtype data constructors+        ; when (isNewTyCon tc) (checkNewDataCon con)++          -- Check that existentials are allowed if they are used+        ; checkTc (existential_ok || isVanillaDataCon con)+                  (badExistential con)++          -- Check that UNPACK pragmas and bangs work out+          -- E.g.  reject   data T = MkT {-# UNPACK #-} Int     -- No "!"+          --                data T = MkT {-# UNPACK #-} !a      -- Can't unpack+        ; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..]++          -- Check the dcUserTyVarBinders invariant+          -- See Note [DataCon user type variable binders] in DataCon+          -- checked here because we sometimes build invalid DataCons before+          -- erroring above here+        ; when debugIsOn $+          do { let (univs, exs, eq_spec, _, _, _) = dataConFullSig con+                   user_tvs                       = dataConUserTyVars con+                   user_tvbs_invariant+                     =    Set.fromList (filterEqSpec eq_spec univs ++ exs)+                       == Set.fromList user_tvs+             ; WARN( not user_tvbs_invariant+                       , vcat ([ ppr con+                               , ppr univs+                               , ppr exs+                               , ppr eq_spec+                               , ppr user_tvs ])) return () }++        ; traceTc "Done validity of data con" $+          vcat [ ppr con+               , text "Datacon user type:" <+> ppr (dataConUserType con)+               , text "Datacon rep type:" <+> ppr (dataConRepType con)+               , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con))+               , case tyConFamInst_maybe (dataConTyCon con) of+                   Nothing -> text "not family"+                   Just (f, _) -> ppr (tyConBinders f) ]+    }+  where+    ctxt = ConArgCtxt (dataConName con)++    check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM ()+    check_bang (HsSrcBang _ _ SrcLazy) _ n+      | not (xopt LangExt.StrictData dflags)+      = addErrTc+          (bad_bang n (text "Lazy annotation (~) without StrictData"))+    check_bang (HsSrcBang _ want_unpack strict_mark) rep_bang n+      | isSrcUnpacked want_unpack, not is_strict+      = addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'"))+      | isSrcUnpacked want_unpack+      , case rep_bang of { HsUnpack {} -> False; _ -> True }+      -- If not optimising, we don't unpack (rep_bang is never+      -- HsUnpack), so don't complain!  This happens, e.g., in Haddock.+      -- See dataConSrcToImplBang.+      , not (gopt Opt_OmitInterfacePragmas dflags)+      -- When typechecking an indefinite package in Backpack, we+      -- may attempt to UNPACK an abstract type.  The test here will+      -- conclude that this is unusable, but it might become usable+      -- when we actually fill in the abstract type.  As such, don't+      -- warn in this case (it gives users the wrong idea about whether+      -- or not UNPACK on abstract types is supported; it is!)+      , unitIdIsDefinite (thisPackage dflags)+      = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma"))+      where+        is_strict = case strict_mark of+                      NoSrcStrict -> xopt LangExt.StrictData dflags+                      bang        -> isSrcStrict bang++    check_bang _ _ _+      = return ()++    bad_bang n herald+      = hang herald 2 (text "on the" <+> speakNth n+                       <+> text "argument of" <+> quotes (ppr con))+-------------------------------+checkNewDataCon :: DataCon -> TcM ()+-- Further checks for the data constructor of a newtype+checkNewDataCon con+  = do  { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys))+              -- One argument++        ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes+        ; let allowedArgType =+                unlifted_newtypes || isLiftedType_maybe arg_ty1 == Just True+        ; checkTc allowedArgType $ vcat+          [ text "A newtype cannot have an unlifted argument type"+          , text "Perhaps you intended to use UnliftedNewtypes"+          ]++        ; check_con (null eq_spec) $+          text "A newtype constructor must have a return type of form T a1 ... an"+                -- Return type is (T a b c)++        ; check_con (null theta) $+          text "A newtype constructor cannot have a context in its type"++        ; check_con (null ex_tvs) $+          text "A newtype constructor cannot have existential type variables"+                -- No existentials++        ; checkTc (all ok_bang (dataConSrcBangs con))+                  (newtypeStrictError con)+                -- No strictness annotations+    }+  where+    (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)+      = dataConFullSig con+    check_con what msg+       = checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConUserType con))++    (arg_ty1 : _) = arg_tys++    ok_bang (HsSrcBang _ _ SrcStrict) = False+    ok_bang (HsSrcBang _ _ SrcLazy)   = False+    ok_bang _                         = True++-------------------------------+checkValidClass :: Class -> TcM ()+checkValidClass cls+  = do  { constrained_class_methods <- xoptM LangExt.ConstrainedClassMethods+        ; multi_param_type_classes  <- xoptM LangExt.MultiParamTypeClasses+        ; nullary_type_classes      <- xoptM LangExt.NullaryTypeClasses+        ; fundep_classes            <- xoptM LangExt.FunctionalDependencies+        ; undecidable_super_classes <- xoptM LangExt.UndecidableSuperClasses++        -- Check that the class is unary, unless multiparameter type classes+        -- are enabled; also recognize deprecated nullary type classes+        -- extension (subsumed by multiparameter type classes, #8993)+        ; checkTc (multi_param_type_classes || cls_arity == 1 ||+                    (nullary_type_classes && cls_arity == 0))+                  (classArityErr cls_arity cls)+        ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls)++        -- Check the super-classes+        ; checkValidTheta (ClassSCCtxt (className cls)) theta++          -- Now check for cyclic superclasses+          -- If there are superclass cycles, checkClassCycleErrs bails.+        ; unless undecidable_super_classes $+          case checkClassCycles cls of+             Just err -> setSrcSpan (getSrcSpan cls) $+                         addErrTc err+             Nothing  -> return ()++        -- Check the class operations.+        -- But only if there have been no earlier errors+        -- See Note [Abort when superclass cycle is detected]+        ; whenNoErrs $+          mapM_ (check_op constrained_class_methods) op_stuff++        -- Check the associated type defaults are well-formed and instantiated+        ; mapM_ check_at at_stuff  }+  where+    (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls+    cls_arity = length (tyConVisibleTyVars (classTyCon cls))+       -- Ignore invisible variables+    cls_tv_set = mkVarSet tyvars++    check_op constrained_class_methods (sel_id, dm)+      = setSrcSpan (getSrcSpan sel_id) $+        addErrCtxt (classOpCtxt sel_id op_ty) $ do+        { traceTc "class op type" (ppr op_ty)+        ; checkValidType ctxt op_ty+                -- This implements the ambiguity check, among other things+                -- Example: tc223+                --   class Error e => Game b mv e | b -> mv e where+                --      newBoard :: MonadState b m => m ()+                -- Here, MonadState has a fundep m->b, so newBoard is fine++           -- a method cannot be levity polymorphic, as we have to store the+           -- method in a dictionary+           -- example of what this prevents:+           --   class BoundedX (a :: TYPE r) where minBound :: a+           -- See Note [Levity polymorphism checking] in DsMonad+        ; checkForLevPoly empty tau1++        ; unless constrained_class_methods $+          mapM_ check_constraint (tail (cls_pred:op_theta))++        ; check_dm ctxt sel_id cls_pred tau2 dm+        }+        where+          ctxt    = FunSigCtxt op_name True -- Report redundant class constraints+          op_name = idName sel_id+          op_ty   = idType sel_id+          (_,cls_pred,tau1) = tcSplitMethodTy op_ty+          -- See Note [Splitting nested sigma types in class type signatures]+          (_,op_theta,tau2) = tcSplitNestedSigmaTys tau1++          check_constraint :: TcPredType -> TcM ()+          check_constraint pred -- See Note [Class method constraints]+            = when (not (isEmptyVarSet pred_tvs) &&+                    pred_tvs `subVarSet` cls_tv_set)+                   (addErrTc (badMethPred sel_id pred))+            where+              pred_tvs = tyCoVarsOfType pred++    check_at (ATI fam_tc m_dflt_rhs)+      = do { checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs)+                     (noClassTyVarErr cls fam_tc)+                        -- Check that the associated type mentions at least+                        -- one of the class type variables+                        -- The check is disabled for nullary type classes,+                        -- since there is no possible ambiguity (#10020)++             -- Check that any default declarations for associated types are valid+           ; whenIsJust m_dflt_rhs $ \ (rhs, loc) ->+             setSrcSpan loc $+             tcAddFamInstCtxt (text "default type instance") (getName fam_tc) $+             checkValidTyFamEqn fam_tc fam_tvs (mkTyVarTys fam_tvs) rhs }+        where+          fam_tvs = tyConTyVars fam_tc++    check_dm :: UserTypeCtxt -> Id -> PredType -> Type -> DefMethInfo -> TcM ()+    -- Check validity of the /top-level/ generic-default type+    -- E.g for   class C a where+    --             default op :: forall b. (a~b) => blah+    -- we do not want to do an ambiguity check on a type with+    -- a free TyVar 'a' (#11608).  See TcType+    -- Note [TyVars and TcTyVars during type checking] in TcType+    -- Hence the mkDefaultMethodType to close the type.+    check_dm ctxt sel_id vanilla_cls_pred vanilla_tau+             (Just (dm_name, dm_spec@(GenericDM dm_ty)))+      = setSrcSpan (getSrcSpan dm_name) $ do+            -- We have carefully set the SrcSpan on the generic+            -- default-method Name to be that of the generic+            -- default type signature++          -- First, we check that that the method's default type signature+          -- aligns with the non-default type signature.+          -- See Note [Default method type signatures must align]+          let cls_pred = mkClassPred cls $ mkTyVarTys $ classTyVars cls+              -- Note that the second field of this tuple contains the context+              -- of the default type signature, making it apparent that we+              -- ignore method contexts completely when validity-checking+              -- default type signatures. See the end of+              -- Note [Default method type signatures must align]+              -- to learn why this is OK.+              --+              -- See also+              -- Note [Splitting nested sigma types in class type signatures]+              -- for an explanation of why we don't use tcSplitSigmaTy here.+              (_, _, dm_tau) = tcSplitNestedSigmaTys dm_ty++              -- Given this class definition:+              --+              --  class C a b where+              --    op         :: forall p q. (Ord a, D p q)+              --               => a -> b -> p -> (a, b)+              --    default op :: forall r s. E r+              --               => a -> b -> s -> (a, b)+              --+              -- We want to match up two types of the form:+              --+              --   Vanilla type sig: C aa bb => aa -> bb -> p -> (aa, bb)+              --   Default type sig: C a  b  => a  -> b  -> s -> (a,  b)+              --+              -- Notice that the two type signatures can be quantified over+              -- different class type variables! Therefore, it's important that+              -- we include the class predicate parts to match up a with aa and+              -- b with bb.+              vanilla_phi_ty = mkPhiTy [vanilla_cls_pred] vanilla_tau+              dm_phi_ty      = mkPhiTy [cls_pred] dm_tau++          traceTc "check_dm" $ vcat+              [ text "vanilla_phi_ty" <+> ppr vanilla_phi_ty+              , text "dm_phi_ty"      <+> ppr dm_phi_ty ]++          -- Actually checking that the types align is done with a call to+          -- tcMatchTys. We need to get a match in both directions to rule+          -- out degenerate cases like these:+          --+          --  class Foo a where+          --    foo1         :: a -> b+          --    default foo1 :: a -> Int+          --+          --    foo2         :: a -> Int+          --    default foo2 :: a -> b+          unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty]+                                      [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $+               hang (text "The default type signature for"+                     <+> ppr sel_id <> colon)+                 2 (ppr dm_ty)+            $$ (text "does not match its corresponding"+                <+> text "non-default type signature")++          -- Now do an ambiguity check on the default type signature.+          checkValidType ctxt (mkDefaultMethodType cls sel_id dm_spec)+    check_dm _ _ _ _ _ = return ()++checkFamFlag :: Name -> TcM ()+-- Check that we don't use families without -XTypeFamilies+-- The parser won't even parse them, but I suppose a GHC API+-- client might have a go!+checkFamFlag tc_name+  = do { idx_tys <- xoptM LangExt.TypeFamilies+       ; checkTc idx_tys err_msg }+  where+    err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name))+                 2 (text "Enable TypeFamilies to allow indexed type families")++checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcM ()+checkResultSigFlag tc_name (TyVarSig _ tvb)+  = do { ty_fam_deps <- xoptM LangExt.TypeFamilyDependencies+       ; checkTc ty_fam_deps $+         hang (text "Illegal result type variable" <+> ppr tvb <+> text "for" <+> quotes (ppr tc_name))+            2 (text "Enable TypeFamilyDependencies to allow result variable names") }+checkResultSigFlag _ _ = return ()  -- other cases OK++{- Note [Class method constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Haskell 2010 is supposed to reject+  class C a where+    op :: Eq a => a -> a+where the method type constrains only the class variable(s).  (The extension+-XConstrainedClassMethods switches off this check.)  But regardless+we should not reject+  class C a where+    op :: (?x::Int) => a -> a+as pointed out in #11793. So the test here rejects the program if+  * -XConstrainedClassMethods is off+  * the tyvars of the constraint are non-empty+  * all the tyvars are class tyvars, none are locally quantified++Note [Abort when superclass cycle is detected]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must avoid doing the ambiguity check for the methods (in+checkValidClass.check_op) when there are already errors accumulated.+This is because one of the errors may be a superclass cycle, and+superclass cycles cause canonicalization to loop. Here is a+representative example:++  class D a => C a where+    meth :: D a => ()+  class C a => D a++This fixes #9415, #9739++Note [Default method type signatures must align]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC enforces the invariant that a class method's default type signature+must "align" with that of the method's non-default type signature, as per+GHC #12918. For instance, if you have:++  class Foo a where+    bar :: forall b. Context => a -> b++Then a default type signature for bar must be alpha equivalent to+(forall b. a -> b). That is, the types must be the same modulo differences in+contexts. So the following would be acceptable default type signatures:++    default bar :: forall b. Context1 => a -> b+    default bar :: forall x. Context2 => a -> x++But the following are NOT acceptable default type signatures:++    default bar :: forall b. b -> a+    default bar :: forall x. x+    default bar :: a -> Int++Note that a is bound by the class declaration for Foo itself, so it is+not allowed to differ in the default type signature.++The default type signature (default bar :: a -> Int) deserves special mention,+since (a -> Int) is a straightforward instantiation of (forall b. a -> b). To+write this, you need to declare the default type signature like so:++    default bar :: forall b. (b ~ Int). a -> b++As noted in #12918, there are several reasons to do this:++1. It would make no sense to have a type that was flat-out incompatible with+   the non-default type signature. For instance, if you had:++     class Foo a where+       bar :: a -> Int+       default bar :: a -> Bool++   Then that would always fail in an instance declaration. So this check+   nips such cases in the bud before they have the chance to produce+   confusing error messages.++2. Internally, GHC uses TypeApplications to instantiate the default method in+   an instance. See Note [Default methods in instances] in TcInstDcls.+   Thus, GHC needs to know exactly what the universally quantified type+   variables are, and when instantiated that way, the default method's type+   must match the expected type.++3. Aesthetically, by only allowing the default type signature to differ in its+   context, we are making it more explicit the ways in which the default type+   signature is less polymorphic than the non-default type signature.++You might be wondering: why are the contexts allowed to be different, but not+the rest of the type signature? That's because default implementations often+rely on assumptions that the more general, non-default type signatures do not.+For instance, in the Enum class declaration:++    class Enum a where+      enum :: [a]+      default enum :: (Generic a, GEnum (Rep a)) => [a]+      enum = map to genum++    class GEnum f where+      genum :: [f a]++The default implementation for enum only works for types that are instances of+Generic, and for which their generic Rep type is an instance of GEnum. But+clearly enum doesn't _have_ to use this implementation, so naturally, the+context for enum is allowed to be different to accomodate this. As a result,+when we validity-check default type signatures, we ignore contexts completely.++Note that when checking whether two type signatures match, we must take care to+split as many foralls as it takes to retrieve the tau types we which to check.+See Note [Splitting nested sigma types in class type signatures].++Note [Splitting nested sigma types in class type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this type synonym and class definition:++  type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t++  class Each s t a b where+    each         ::                                      Traversal s t a b+    default each :: (Traversable g, s ~ g a, t ~ g b) => Traversal s t a b++It might seem obvious that the tau types in both type signatures for `each`+are the same, but actually getting GHC to conclude this is surprisingly tricky.+That is because in general, the form of a class method's non-default type+signature is:++  forall a. C a => forall d. D d => E a b++And the general form of a default type signature is:++  forall f. F f => E a f -- The variable `a` comes from the class++So it you want to get the tau types in each type signature, you might find it+reasonable to call tcSplitSigmaTy twice on the non-default type signature, and+call it once on the default type signature. For most classes and methods, this+will work, but Each is a bit of an exceptional case. The way `each` is written,+it doesn't quantify any additional type variables besides those of the Each+class itself, so the non-default type signature for `each` is actually this:++  forall s t a b. Each s t a b => Traversal s t a b++Notice that there _appears_ to only be one forall. But there's actually another+forall lurking in the Traversal type synonym, so if you call tcSplitSigmaTy+twice, you'll also go under the forall in Traversal! That is, you'll end up+with:++  (a -> f b) -> s -> f t++A problem arises because you only call tcSplitSigmaTy once on the default type+signature for `each`, which gives you++  Traversal s t a b++Or, equivalently:++  forall f. Applicative f => (a -> f b) -> s -> f t++This is _not_ the same thing as (a -> f b) -> s -> f t! So now tcMatchTy will+say that the tau types for `each` are not equal.++A solution to this problem is to use tcSplitNestedSigmaTys instead of+tcSplitSigmaTy. tcSplitNestedSigmaTys will always split any foralls that it+sees until it can't go any further, so if you called it on the default type+signature for `each`, it would return (a -> f b) -> s -> f t like we desired.++Note [Checking partial record field]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This check checks the partial record field selector, and warns (#7169).++For example:++  data T a = A { m1 :: a, m2 :: a } | B { m1 :: a }++The function 'm2' is partial record field, and will fail when it is applied to+'B'. The warning identifies such partial fields. The check is performed at the+declaration of T, not at the call-sites of m2.++The warning can be suppressed by prefixing the field-name with an underscore.+For example:++  data T a = A { m1 :: a, _m2 :: a } | B { m1 :: a }++************************************************************************+*                                                                      *+                Checking role validity+*                                                                      *+************************************************************************+-}++checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcM ()+checkValidRoleAnnots role_annots tc+  | isTypeSynonymTyCon tc = check_no_roles+  | isFamilyTyCon tc      = check_no_roles+  | isAlgTyCon tc         = check_roles+  | otherwise             = return ()+  where+    -- Role annotations are given only on *explicit* variables,+    -- but a tycon stores roles for all variables.+    -- So, we drop the implicit roles (which are all Nominal, anyway).+    name                   = tyConName tc+    roles                  = tyConRoles tc+    (vis_roles, vis_vars)  = unzip $ mapMaybe pick_vis $+                             zip roles (tyConBinders tc)+    role_annot_decl_maybe  = lookupRoleAnnot role_annots name++    pick_vis :: (Role, TyConBinder) -> Maybe (Role, TyVar)+    pick_vis (role, tvb)+      | isVisibleTyConBinder tvb = Just (role, binderVar tvb)+      | otherwise                = Nothing++    check_roles+      = whenIsJust role_annot_decl_maybe $+          \decl@(dL->L loc (RoleAnnotDecl _ _ the_role_annots)) ->+          addRoleAnnotCtxt name $+          setSrcSpan loc $ do+          { role_annots_ok <- xoptM LangExt.RoleAnnotations+          ; checkTc role_annots_ok $ needXRoleAnnotations tc+          ; checkTc (vis_vars `equalLength` the_role_annots)+                    (wrongNumberOfRoles vis_vars decl)+          ; _ <- zipWith3M checkRoleAnnot vis_vars the_role_annots vis_roles+          -- Representational or phantom roles for class parameters+          -- quickly lead to incoherence. So, we require+          -- IncoherentInstances to have them. See #8773, #14292+          ; incoherent_roles_ok <- xoptM LangExt.IncoherentInstances+          ; checkTc (  incoherent_roles_ok+                    || (not $ isClassTyCon tc)+                    || (all (== Nominal) vis_roles))+                    incoherentRoles++          ; lint <- goptM Opt_DoCoreLinting+          ; when lint $ checkValidRoles tc }++    check_no_roles+      = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl++checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM ()+checkRoleAnnot _  (dL->L _ Nothing)   _  = return ()+checkRoleAnnot tv (dL->L _ (Just r1)) r2+  = when (r1 /= r2) $+    addErrTc $ badRoleAnnot (tyVarName tv) r1 r2+checkRoleAnnot _ _ _ = panic "checkRoleAnnot: Impossible Match" -- due to #15884++-- This is a double-check on the role inference algorithm. It is only run when+-- -dcore-lint is enabled. See Note [Role inference] in TcTyDecls+checkValidRoles :: TyCon -> TcM ()+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism] in CoreLint+checkValidRoles tc+  | isAlgTyCon tc+    -- tyConDataCons returns an empty list for data families+  = mapM_ check_dc_roles (tyConDataCons tc)+  | Just rhs <- synTyConRhs_maybe tc+  = check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs+  | otherwise+  = return ()+  where+    check_dc_roles datacon+      = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc))+           ; mapM_ (check_ty_roles role_env Representational) $+                    eqSpecPreds eq_spec ++ theta ++ arg_tys }+                    -- See Note [Role-checking data constructor arguments] in TcTyDecls+      where+        (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)+          = dataConFullSig datacon+        univ_roles = zipVarEnv univ_tvs (tyConRoles tc)+              -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs+        ex_roles   = mkVarEnv (map (, Nominal) ex_tvs)+        role_env   = univ_roles `plusVarEnv` ex_roles++    check_ty_roles env role ty+      | Just ty' <- coreView ty -- #14101+      = check_ty_roles env role ty'++    check_ty_roles env role (TyVarTy tv)+      = case lookupVarEnv env tv of+          Just role' -> unless (role' `ltRole` role || role' == role) $+                        report_error $ text "type variable" <+> quotes (ppr tv) <+>+                                       text "cannot have role" <+> ppr role <+>+                                       text "because it was assigned role" <+> ppr role'+          Nothing    -> report_error $ text "type variable" <+> quotes (ppr tv) <+>+                                       text "missing in environment"++    check_ty_roles env Representational (TyConApp tc tys)+      = let roles' = tyConRoles tc in+        zipWithM_ (maybe_check_ty_roles env) roles' tys++    check_ty_roles env Nominal (TyConApp _ tys)+      = mapM_ (check_ty_roles env Nominal) tys++    check_ty_roles _   Phantom ty@(TyConApp {})+      = pprPanic "check_ty_roles" (ppr ty)++    check_ty_roles env role (AppTy ty1 ty2)+      =  check_ty_roles env role    ty1+      >> check_ty_roles env Nominal ty2++    check_ty_roles env role (FunTy _ ty1 ty2)+      =  check_ty_roles env role ty1+      >> check_ty_roles env role ty2++    check_ty_roles env role (ForAllTy (Bndr tv _) ty)+      =  check_ty_roles env Nominal (tyVarKind tv)+      >> check_ty_roles (extendVarEnv env tv Nominal) role ty++    check_ty_roles _   _    (LitTy {}) = return ()++    check_ty_roles env role (CastTy t _)+      = check_ty_roles env role t++    check_ty_roles _   role (CoercionTy co)+      = unless (role == Phantom) $+        report_error $ text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role++    maybe_check_ty_roles env role ty+      = when (role == Nominal || role == Representational) $+        check_ty_roles env role ty++    report_error doc+      = addErrTc $ vcat [text "Internal error in role inference:",+                         doc,+                         text "Please report this as a GHC bug:  https://www.haskell.org/ghc/reportabug"]++{-+************************************************************************+*                                                                      *+                Error messages+*                                                                      *+************************************************************************+-}++tcAddTyFamInstCtxt :: TyFamInstDecl GhcRn -> TcM a -> TcM a+tcAddTyFamInstCtxt decl+  = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl)++tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc+tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn =+                            HsIB { hsib_body = eqn }})+  = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance")+                    (unLoc (feqn_tycon eqn))+tcMkDataFamInstCtxt (DataFamInstDecl (XHsImplicitBndrs nec))+  = noExtCon nec++tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a+tcAddDataFamInstCtxt decl+  = addErrCtxt (tcMkDataFamInstCtxt decl)++tcMkFamInstCtxt :: SDoc -> Name -> SDoc+tcMkFamInstCtxt flavour tycon+  = hsep [ text "In the" <+> flavour <+> text "declaration for"+         , quotes (ppr tycon) ]++tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a+tcAddFamInstCtxt flavour tycon thing_inside+  = addErrCtxt (tcMkFamInstCtxt flavour tycon) thing_inside++tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a+tcAddClosedTypeFamilyDeclCtxt tc+  = addErrCtxt ctxt+  where+    ctxt = text "In the equations for closed type family" <+>+           quotes (ppr tc)++resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc+resultTypeMisMatch field_name con1 con2+  = vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,+                text "have a common field" <+> quotes (ppr field_name) <> comma],+          nest 2 $ text "but have different result types"]++fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc+fieldTypeMisMatch field_name con1 con2+  = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,+         text "give different types for field", quotes (ppr field_name)]++dataConCtxtName :: [Located Name] -> SDoc+dataConCtxtName [con]+   = text "In the definition of data constructor" <+> quotes (ppr con)+dataConCtxtName con+   = text "In the definition of data constructors" <+> interpp'SP con++dataConCtxt :: Outputable a => a -> SDoc+dataConCtxt con = text "In the definition of data constructor" <+> quotes (ppr con)++classOpCtxt :: Var -> Type -> SDoc+classOpCtxt sel_id tau = sep [text "When checking the class method:",+                              nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)]++classArityErr :: Int -> Class -> SDoc+classArityErr n cls+    | n == 0 = mkErr "No" "no-parameter"+    | otherwise = mkErr "Too many" "multi-parameter"+  where+    mkErr howMany allowWhat =+        vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls),+              parens (text ("Enable MultiParamTypeClasses to allow "+                                    ++ allowWhat ++ " classes"))]++classFunDepsErr :: Class -> SDoc+classFunDepsErr cls+  = vcat [text "Fundeps in class" <+> quotes (ppr cls),+          parens (text "Enable FunctionalDependencies to allow fundeps")]++badMethPred :: Id -> TcPredType -> SDoc+badMethPred sel_id pred+  = vcat [ hang (text "Constraint" <+> quotes (ppr pred)+                 <+> text "in the type of" <+> quotes (ppr sel_id))+              2 (text "constrains only the class type variables")+         , text "Enable ConstrainedClassMethods to allow it" ]++noClassTyVarErr :: Class -> TyCon -> SDoc+noClassTyVarErr clas fam_tc+  = sep [ text "The associated type" <+> quotes (ppr fam_tc <+> hsep (map ppr (tyConTyVars fam_tc)))+        , text "mentions none of the type or kind variables of the class" <+>+                quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))]++badDataConTyCon :: DataCon -> Type -> SDoc+badDataConTyCon data_con res_ty_tmpl+  | ASSERT( all isTyVar tvs )+    tcIsForAllTy actual_res_ty+  = nested_foralls_contexts_suggestion+  | isJust (tcSplitPredFunTy_maybe actual_res_ty)+  = nested_foralls_contexts_suggestion+  | otherwise+  = hang (text "Data constructor" <+> quotes (ppr data_con) <+>+                text "returns type" <+> quotes (ppr actual_res_ty))+       2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl))+  where+    actual_res_ty = dataConOrigResTy data_con++    -- This suggestion is useful for suggesting how to correct code like what+    -- was reported in #12087:+    --+    --   data F a where+    --     MkF :: Ord a => Eq a => a -> F a+    --+    -- Although nested foralls or contexts are allowed in function type+    -- signatures, it is much more difficult to engineer GADT constructor type+    -- signatures to allow something similar, so we error in the latter case.+    -- Nevertheless, we can at least suggest how a user might reshuffle their+    -- exotic GADT constructor type signature so that GHC will accept.+    nested_foralls_contexts_suggestion =+      text "GADT constructor type signature cannot contain nested"+      <+> quotes forAllLit <> text "s or contexts"+      $+$ hang (text "Suggestion: instead use this type signature:")+             2 (ppr (dataConName data_con) <+> dcolon <+> ppr suggested_ty)++    -- To construct a type that GHC would accept (suggested_ty), we:+    --+    -- 1) Find the existentially quantified type variables and the class+    --    predicates from the datacon. (NB: We don't need the universally+    --    quantified type variables, since rejigConRes won't substitute them in+    --    the result type if it fails, as in this scenario.)+    -- 2) Split apart the return type (which is headed by a forall or a+    --    context) using tcSplitNestedSigmaTys, collecting the type variables+    --    and class predicates we find, as well as the rho type lurking+    --    underneath the nested foralls and contexts.+    -- 3) Smash together the type variables and class predicates from 1) and+    --    2), and prepend them to the rho type from 2).+    (tvs, theta, rho) = tcSplitNestedSigmaTys (dataConUserType data_con)+    suggested_ty = mkSpecSigmaTy tvs theta rho++badGadtDecl :: Name -> SDoc+badGadtDecl tc_name+  = vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name)+         , nest 2 (parens $ text "Enable the GADTs extension to allow this") ]++badExistential :: DataCon -> SDoc+badExistential con+  = hang (text "Data constructor" <+> quotes (ppr con) <+>+                text "has existential type variables, a context, or a specialised result type")+       2 (vcat [ ppr con <+> dcolon <+> ppr (dataConUserType con)+               , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ])++badStupidTheta :: Name -> SDoc+badStupidTheta tc_name+  = text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name)++newtypeConError :: Name -> Int -> SDoc+newtypeConError tycon n+  = sep [text "A newtype must have exactly one constructor,",+         nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ]++newtypeStrictError :: DataCon -> SDoc+newtypeStrictError con+  = sep [text "A newtype constructor cannot have a strictness annotation,",+         nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"]++newtypeFieldErr :: DataCon -> Int -> SDoc+newtypeFieldErr con_name n_flds+  = sep [text "The constructor of a newtype must have exactly one field",+         nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds]++badSigTyDecl :: Name -> SDoc+badSigTyDecl tc_name+  = vcat [ text "Illegal kind signature" <+>+           quotes (ppr tc_name)+         , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ]++emptyConDeclsErr :: Name -> SDoc+emptyConDeclsErr tycon+  = sep [quotes (ppr tycon) <+> text "has no constructors",+         nest 2 $ text "(EmptyDataDecls permits this)"]++wrongKindOfFamily :: TyCon -> SDoc+wrongKindOfFamily family+  = text "Wrong category of family instance; declaration was for a"+    <+> kindOfFamily+  where+    kindOfFamily | isTypeFamilyTyCon family = text "type family"+                 | isDataFamilyTyCon family = text "data family"+                 | otherwise = pprPanic "wrongKindOfFamily" (ppr family)++-- | Produce an error for oversaturated type family equations with too many+-- required arguments.+-- See Note [Oversaturated type family equations] in TcValidity.+wrongNumberOfParmsErr :: Arity -> SDoc+wrongNumberOfParmsErr max_args+  = text "Number of parameters must match family declaration; expected"+    <+> ppr max_args++badRoleAnnot :: Name -> Role -> Role -> SDoc+badRoleAnnot var annot inferred+  = hang (text "Role mismatch on variable" <+> ppr var <> colon)+       2 (sep [ text "Annotation says", ppr annot+              , text "but role", ppr inferred+              , text "is required" ])++wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc+wrongNumberOfRoles tyvars d@(dL->L _ (RoleAnnotDecl _ _ annots))+  = hang (text "Wrong number of roles listed in role annotation;" $$+          text "Expected" <+> (ppr $ length tyvars) <> comma <+>+          text "got" <+> (ppr $ length annots) <> colon)+       2 (ppr d)+wrongNumberOfRoles _ (dL->L _ (XRoleAnnotDecl nec)) = noExtCon nec+wrongNumberOfRoles _ _ = panic "wrongNumberOfRoles: Impossible Match"+                         -- due to #15884+++illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM ()+illegalRoleAnnotDecl (dL->L loc (RoleAnnotDecl _ tycon _))+  = setErrCtxt [] $+    setSrcSpan loc $+    addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$+              text "they are allowed only for datatypes and classes.")+illegalRoleAnnotDecl (dL->L _ (XRoleAnnotDecl nec)) = noExtCon nec illegalRoleAnnotDecl _ = panic "illegalRoleAnnotDecl: Impossible Match"                          -- due to #15884
compiler/typecheck/TcTyDecls.hs view
@@ -10,6 +10,7 @@ -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -26,18 +27,19 @@         tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector     ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude  import TcRnMonad import TcEnv-import TcBinds( tcValBinds, addTypecheckedBinds )+import TcBinds( tcValBinds ) import TyCoRep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) ) import TcType+import Predicate import TysWiredIn( unitTy ) import MkCore( rEC_SEL_ERROR_ID )-import HsSyn+import GHC.Hs import Class import Type import HscTypes@@ -82,14 +84,14 @@   = nameEnvElts (go ty)   where      go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim-     go (TyConApp tc tys)         = go_tc tc `plusNameEnv` go_s tys-     go (LitTy _)                 = emptyNameEnv-     go (TyVarTy _)               = emptyNameEnv-     go (AppTy a b)               = go a `plusNameEnv` go b-     go (FunTy a b)               = go a `plusNameEnv` go b-     go (ForAllTy _ ty)           = go ty-     go (CastTy ty co)            = go ty `plusNameEnv` go_co co-     go (CoercionTy co)           = go_co co+     go (TyConApp tc tys) = go_tc tc `plusNameEnv` go_s tys+     go (LitTy _)         = emptyNameEnv+     go (TyVarTy _)       = emptyNameEnv+     go (AppTy a b)       = go a `plusNameEnv` go b+     go (FunTy _ a b)     = go a `plusNameEnv` go b+     go (ForAllTy _ ty)   = go ty+     go (CastTy ty co)    = go ty `plusNameEnv` go_co co+     go (CoercionTy co)   = go_co co       -- Note [TyCon cycles through coercions?!]      -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -149,12 +151,10 @@ -- a failure message reporting that a cycle was found. newtype SynCycleM a = SynCycleM {     runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) }+    deriving (Functor)  type SynCycleState = NameSet -instance Functor SynCycleM where-    fmap = liftM- instance Applicative SynCycleM where     pure x = SynCycleM $ \state -> Right (x, state)     (<*>) = ap@@ -598,7 +598,7 @@                                           lcls' = extendVarSet lcls tv                                     ; markNominal lcls (tyVarKind tv)                                     ; go lcls' ty }-    go lcls (FunTy arg res)    = go lcls arg >> go lcls res+    go lcls (FunTy _ arg res)  = go lcls arg >> go lcls res     go _    (LitTy {})         = return ()       -- See Note [Coercions in role inference]     go lcls (CastTy ty _)      = go lcls ty@@ -634,7 +634,7 @@     get_ty_vars :: Type -> FV     get_ty_vars (TyVarTy tv)      = unitFV tv     get_ty_vars (AppTy t1 t2)     = get_ty_vars t1 `unionFV` get_ty_vars t2-    get_ty_vars (FunTy t1 t2)     = get_ty_vars t1 `unionFV` get_ty_vars t2+    get_ty_vars (FunTy _ t1 t2)   = get_ty_vars t1 `unionFV` get_ty_vars t2     get_ty_vars (TyConApp _ tys)  = mapUnionFV get_ty_vars tys     get_ty_vars (ForAllTy tvb ty) = tyCoFVsBndr tvb (get_ty_vars ty)     get_ty_vars (LitTy {})        = emptyFV@@ -677,9 +677,7 @@                             -> Int          -- size of VarPositions                             -> RoleInferenceState                             -> (a, RoleInferenceState) }--instance Functor RoleM where-    fmap = liftM+    deriving (Functor)  instance Applicative RoleM where     pure x = RM $ \_ _ _ state -> (x, state)@@ -792,7 +790,7 @@      --     used in code generated by the fill-in for missing      --     methods in instances (TcInstDcls.mkDefMethBind), and      --     then typechecked.  So we need the right visibilty info-     --     (Trac #13998)+     --     (#13998)  {- ************************************************************************@@ -805,7 +803,7 @@ {- Note [Default method Ids and Template Haskell] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (Trac #4169):+Consider this (#4169):    class Numeric a where      fromIntegerNum :: a      fromIntegerNum = ...@@ -835,8 +833,8 @@                                      tcValBinds TopLevel binds sigs getGblEnv        ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) }   where-    sigs = [ cL loc (IdSig noExt sel_id)   | (sel_id, _) <- sel_bind_prs-                                          , let loc = getSrcSpan sel_id ]+    sigs = [ cL loc (IdSig noExtField sel_id) | (sel_id, _) <- sel_bind_prs+                                              , let loc = getSrcSpan sel_id ]     binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs]  mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)]@@ -878,7 +876,7 @@     sel_ty | is_naughty = unitTy  -- See Note [Naughty record selectors]            | otherwise  = mkSpecForAllTys data_tvs          $                           mkPhiTy (conLikeStupidTheta con1) $   -- Urgh!-                          mkFunTy data_ty                   $+                          mkVisFunTy data_ty                $                           mkSpecForAllTys field_tvs         $                           mkPhiTy field_theta               $                           -- req_theta is empty for normal DataCon@@ -895,7 +893,7 @@              | otherwise =  map mk_match cons_w_field ++ deflt     mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname)                                  [cL loc (mk_sel_pat con)]-                                 (cL loc (HsVar noExt (cL loc field_var)))+                                 (cL loc (HsVar noExtField (cL loc field_var)))     mk_sel_pat con = ConPatIn (cL loc (getName con)) (RecCon rec_fields)     rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }     rec_field  = noLoc (HsRecField@@ -903,7 +901,7 @@                            = cL loc (FieldOcc sel_name                                      (cL loc $ mkVarUnqual lbl))                         , hsRecFieldArg-                           = cL loc (VarPat noExt (cL loc field_var))+                           = cL loc (VarPat noExtField (cL loc field_var))                         , hsRecPun = False })     sel_lname = cL loc sel_name     field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc@@ -913,10 +911,10 @@     -- mentions this particular record selector     deflt | all dealt_with all_cons = []           | otherwise = [mkSimpleMatch CaseAlt-                            [cL loc (WildPat noExt)]-                            (mkHsApp (cL loc (HsVar noExt+                            [cL loc (WildPat noExtField)]+                            (mkHsApp (cL loc (HsVar noExtField                                          (cL loc (getName rEC_SEL_ERROR_ID))))-                                     (cL loc (HsLit noExt msg_lit)))]+                                     (cL loc (HsLit noExtField msg_lit)))]          -- Do not add a default case unless there are unmatched         -- constructors.  We must take account of GADTs, else we@@ -938,7 +936,7 @@     inst_tys = substTyVars eq_subst univ_tvs      unit_rhs = mkLHsTupleExpr []-    msg_lit = HsStringPrim NoSourceText (fastStringToByteString lbl)+    msg_lit = HsStringPrim NoSourceText (bytesFS lbl)  {- Note [Polymorphic selectors]
compiler/typecheck/TcTypeNats.hs view
@@ -29,7 +29,7 @@ import TyCon      ( TyCon, FamTyConFlav(..), mkFamilyTyCon                   , Injectivity(..) ) import Coercion   ( Role(..) )-import TcRnTypes  ( Xi )+import Constraint ( Xi ) import CoAxiom    ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn ) import Name       ( Name, BuiltInSyntax(..) ) import TysWiredIn@@ -69,7 +69,7 @@  See also the Wiki page: -    https://ghc.haskell.org/trac/ghc/wiki/TypeNats+    https://gitlab.haskell.org/ghc/ghc/wikis/type-nats  Note [Adding built-in type families] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/typecheck/TcTypeable.hs view
@@ -3,23 +3,24 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1999 -} +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} -module TcTypeable(mkTypeableBinds) where+module TcTypeable(mkTypeableBinds, tyConIsTypeable) where +#include "HsVersions.h"  import GhcPrelude  import BasicTypes ( Boxity(..), neverInlinePragma, SourceText(..) )-import TcBinds( addTypecheckedBinds ) import IfaceEnv( newGlobalBinder ) import TyCoRep( Type(..), TyLit(..) ) import TcEnv import TcEvidence ( mkWpTyApps ) import TcRnMonad-import TcTypeableValidity+import TcType import HscTypes ( lookupId ) import PrelNames import TysPrim ( primTyCons )@@ -32,7 +33,7 @@ import TyCon import DataCon import Module-import HsSyn+import GHC.Hs import DynFlags import Bag import Var ( VarBndr(..) )@@ -44,6 +45,7 @@  import Control.Monad.Trans.State import Control.Monad.Trans.Class (lift)+import Data.Maybe ( isJust ) import Data.Word( Word64 )  {- Note [Grand plan for Typeable]@@ -146,7 +148,9 @@ -- See Note [Grand plan for Typeable] in TcTypeable. mkTypeableBinds :: TcM TcGblEnv mkTypeableBinds-  = do { -- Create a binding for $trModule.+  = do { dflags <- getDynFlags+       ; if gopt Opt_NoTypeableBinds dflags then getGblEnv else do+       { -- Create a binding for $trModule.          -- Do this before processing any data type declarations,          -- which need tcg_tr_module to be initialised        ; tcg_env <- mkModIdBindings@@ -164,7 +168,7 @@        ; traceTc "mkTypeableBinds" (ppr tycons)        ; this_mod_todos <- todoForTyCons mod mod_id tycons        ; mkTypeRepTodoBinds (this_mod_todos : prim_todos)-       } }+       } } }   where     needs_typeable_binds tc       | tc `elem` [runtimeRepTyCon, vecCountTyCon, vecElemTyCon]@@ -250,7 +254,7 @@               -- Do, however, make them for their promoted datacon (see #13915).             , not $ isFamInstTyCon tc''             , Just rep_name <- pure $ tyConRepName_maybe tc''-            , typeIsTypeable $ dropForAlls $ tyConKind tc''+            , tyConIsTypeable tc''             ]     return TypeRepTodo { mod_rep_expr    = nlHsVar mod_id                        , pkg_fingerprint = pkg_fpr@@ -397,7 +401,7 @@ -- | Make Typeable bindings for the given 'TyCon'. mkTyConRepBinds :: TypeableStuff -> TypeRepTodo                 -> TypeableTyCon -> KindRepM (LHsBinds GhcTc)-mkTyConRepBinds stuff@(Stuff {..}) todo (TypeableTyCon {..})+mkTyConRepBinds stuff todo (TypeableTyCon {..})   = do -- Make a KindRep        let (bndrs, kind) = splitForAllVarBndrs (tyConKind tycon)        liftTc $ traceTc "mkTyConKindRepBinds"@@ -410,6 +414,36 @@            tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs        return $ unitBag tycon_rep_bind +-- | Is a particular 'TyCon' representable by @Typeable@?. These exclude type+-- families and polytypes.+tyConIsTypeable :: TyCon -> Bool+tyConIsTypeable tc =+       isJust (tyConRepName_maybe tc)+    && kindIsTypeable (dropForAlls $ tyConKind tc)++-- | Is a particular 'Kind' representable by @Typeable@? Here we look for+-- polytypes and types containing casts (which may be, for instance, a type+-- family).+kindIsTypeable :: Kind -> Bool+-- We handle types of the form (TYPE LiftedRep) specifically to avoid+-- looping on (tyConIsTypeable RuntimeRep). We used to consider (TYPE rr)+-- to be typeable without inspecting rr, but this exhibits bad behavior+-- when rr is a type family.+kindIsTypeable ty+  | Just ty' <- coreView ty         = kindIsTypeable ty'+kindIsTypeable ty+  | isLiftedTypeKind ty             = True+kindIsTypeable (TyVarTy _)          = True+kindIsTypeable (AppTy a b)          = kindIsTypeable a && kindIsTypeable b+kindIsTypeable (FunTy _ a b)        = kindIsTypeable a && kindIsTypeable b+kindIsTypeable (TyConApp tc args)   = tyConIsTypeable tc+                                   && all kindIsTypeable args+kindIsTypeable (ForAllTy{})         = False+kindIsTypeable (LitTy _)            = True+kindIsTypeable (CastTy{})           = False+  -- See Note [Typeable instances for casted types]+kindIsTypeable (CoercionTy{})       = False+ -- | Maps kinds to 'KindRep' bindings. This binding may either be defined in -- some other module (in which case the @Maybe (LHsExpr Id@ will be 'Nothing') -- or a binding which we generated in the current module (in which case it will@@ -430,8 +464,8 @@ builtInKindReps :: [(Kind, Name)] builtInKindReps =     [ (star, starKindRepName)-    , (mkFunTy star star, starArrStarKindRepName)-    , (mkFunTys [star, star] star, starArrStarArrStarKindRepName)+    , (mkVisFunTy star star, starArrStarKindRepName)+    , (mkVisFunTys [star, star] star, starArrStarArrStarKindRepName)     ]   where     star = liftedTypeKind@@ -447,7 +481,7 @@ mkExportedKindReps :: TypeableStuff                    -> [(Kind, Id)]  -- ^ the kinds to generate bindings for                    -> KindRepM ()-mkExportedKindReps stuff@(Stuff {..}) = mapM_ kindrep_binding+mkExportedKindReps stuff = mapM_ kindrep_binding   where     empty_scope = mkDeBruijnContext [] @@ -521,8 +555,9 @@         -- We handle (TYPE LiftedRep) etc separately to make it         -- clear to consumers (e.g. serializers) that there is         -- a loop here (as TYPE :: RuntimeRep -> TYPE 'LiftedRep)-      | not (tcIsConstraintKind k)    -- Typeable respects the Constraint/* distinction-                                      -- so do not follow the special case here+      | not (tcIsConstraintKind k)+              -- Typeable respects the Constraint/Type distinction+              -- so do not follow the special case here       , Just arg <- kindRep_maybe k       , Just (tc, []) <- splitTyConApp_maybe arg       , Just dc <- isPromotedDataCon_maybe tc@@ -554,7 +589,7 @@     new_kind_rep (ForAllTy (Bndr var _) ty)       = pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty) -    new_kind_rep (FunTy t1 t2)+    new_kind_rep (FunTy _ t1 t2)       = do rep1 <- getKindRep stuff in_scope t1            rep2 <- getKindRep stuff in_scope t2            return $ nlHsDataCon kindRepFunDataCon@@ -570,6 +605,7 @@                  `nlHsApp` nlHsDataCon typeLitSymbolDataCon                  `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show s) +    -- See Note [Typeable instances for casted types]     new_kind_rep (CastTy ty co)       = pprPanic "mkTyConKindRepBinds.go(cast)" (ppr ty $$ ppr co) @@ -668,6 +704,44 @@                  | KindRepApp KindRep KindRep                  | KindRepFun KindRep KindRep                  ...++Note [Typeable instances for casted types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+At present, GHC does not manufacture TypeReps for types containing casts+(#16835). In theory, GHC could do so today, but it might be dangerous tomorrow.++In today's GHC, we normalize all types before computing their TypeRep.+For example:++    type family F a+    type instance F Int = Type++    data D = forall (a :: F Int). MkD a++    tr :: TypeRep (MkD Bool)+    tr = typeRep++When computing the TypeRep for `MkD Bool` (or rather,+`MkD (Bool |> Sym (FInt[0]))`), we simply discard the cast to obtain the+TypeRep for `MkD Bool`.++Why does this work? If we have a type definition with casts, then the+only coercions that those casts can mention are either Refl, type family+axioms, built-in axioms, and coercions built from those roots. Therefore,+type family (and built-in) axioms will apply precisely when type normalization+succeeds (i.e, the type family applications are reducible). Therefore, it+is safe to ignore the cast entirely when constructing the TypeRep.++This approach would be fragile in a future where GHC permits other forms of+coercions to appear in casts (e.g., coercion quantification as described+in #15710). If GHC permits local assumptions to appear in casts that cannot be+reduced with conventional normalization, then discarding casts would become+unsafe. It would be unfortunate for the Typeable solver to become a roadblock+obstructing such a future, so we deliberately do not implement the ability+for TypeReps to represent types with casts at the moment.++If we do wish to allow this in the future, it will likely require modeling+casts and coercions in TypeReps themselves. -}  mkList :: Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc
− compiler/typecheck/TcTypeableValidity.hs 
@@ -1,46 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1999--}---- | This module is separate from "TcTypeable" because the functions in this--- module are used in "ClsInst", and importing "TcTypeable" from "ClsInst"--- would lead to an import cycle.-module TcTypeableValidity (tyConIsTypeable, typeIsTypeable) where--import GhcPrelude--import TyCoRep-import TyCon-import Type--import Data.Maybe (isJust)---- | Is a particular 'TyCon' representable by @Typeable@?. These exclude type--- families and polytypes.-tyConIsTypeable :: TyCon -> Bool-tyConIsTypeable tc =-       isJust (tyConRepName_maybe tc)-    && typeIsTypeable (dropForAlls $ tyConKind tc)---- | Is a particular 'Type' representable by @Typeable@? Here we look for--- polytypes and types containing casts (which may be, for instance, a type--- family).-typeIsTypeable :: Type -> Bool--- We handle types of the form (TYPE LiftedRep) specifically to avoid--- looping on (tyConIsTypeable RuntimeRep). We used to consider (TYPE rr)--- to be typeable without inspecting rr, but this exhibits bad behavior--- when rr is a type family.-typeIsTypeable ty-  | Just ty' <- coreView ty         = typeIsTypeable ty'-typeIsTypeable ty-  | isLiftedTypeKind ty             = True-typeIsTypeable (TyVarTy _)          = True-typeIsTypeable (AppTy a b)          = typeIsTypeable a && typeIsTypeable b-typeIsTypeable (FunTy a b)          = typeIsTypeable a && typeIsTypeable b-typeIsTypeable (TyConApp tc args)   = tyConIsTypeable tc-                                   && all typeIsTypeable args-typeIsTypeable (ForAllTy{})         = False-typeIsTypeable (LitTy _)            = True-typeIsTypeable (CastTy{})           = False-typeIsTypeable (CoercionTy{})       = False
compiler/typecheck/TcUnify.hs view
@@ -6,7 +6,8 @@ Type subsumption and unification -} -{-# LANGUAGE CPP, MultiWayIf, TupleSections, ScopedTypeVariables #-}+{-# LANGUAGE CPP, DeriveFunctor, MultiWayIf, TupleSections,+    ScopedTypeVariables #-}  module TcUnify (   -- Full-blown subsumption@@ -31,22 +32,26 @@   matchActualFunTys, matchActualFunTysPart,   matchExpectedFunKind, -  metaTyVarUpdateOK, occCheckForErrors, OccCheckResult(..)+  metaTyVarUpdateOK, occCheckForErrors, MetaTyVarUpdateResult(..)    ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude -import HsSyn+import GHC.Hs import TyCoRep+import TyCoPpr( debugPprType ) import TcMType import TcRnMonad import TcType import Type import Coercion import TcEvidence+import Constraint+import Predicate+import TcOrigin import Name( isSystemName ) import Inst import TyCon@@ -63,6 +68,7 @@ import qualified GHC.LanguageExtensions as LangExt import Outputable +import Data.Maybe( isNothing ) import Control.Monad import Control.Arrow ( second ) @@ -153,8 +159,8 @@     go acc_arg_tys n ty       | Just ty' <- tcView ty = go acc_arg_tys n ty' -    go acc_arg_tys n (FunTy arg_ty res_ty)-      = ASSERT( not (isPredTy arg_ty) )+    go acc_arg_tys n (FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty })+      = ASSERT( af == VisArg )         do { (result, wrap_res) <- go (mkCheckExpType arg_ty : acc_arg_tys)                                       (n-1) res_ty            ; return ( result@@ -174,7 +180,7 @@        -- However unlike the meta-tyvar case, we are sure that the        -- number of arguments doesn't match arity of the original        -- type, so we can add a bit more context to the error message-       -- (cf Trac #7869).+       -- (cf #7869).        --        -- It is not always an error, because specialized type may have        -- different arity, for example:@@ -184,7 +190,7 @@        -- > f2 = undefined        --        -- But in that case we add specialized type into error context-       -- anyway, because it may be useful. See also Trac #9605.+       -- anyway, because it may be useful. See also #9605.     go acc_arg_tys n ty = addErrCtxtM mk_ctxt $                           defer acc_arg_tys n (mkCheckExpType ty) @@ -196,7 +202,7 @@            ; result       <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty            ; more_arg_tys <- mapM readExpType more_arg_tys            ; res_ty       <- readExpType res_ty-           ; let unif_fun_ty = mkFunTys more_arg_tys res_ty+           ; let unif_fun_ty = mkVisFunTys more_arg_tys res_ty            ; wrap <- tcSubTypeDS AppOrigin GenSigCtxt unif_fun_ty fun_ty                          -- Not a good origin at all :-(            ; return (result, wrap) }@@ -282,8 +288,8 @@     go n acc_args ty       | Just ty' <- tcView ty = go n acc_args ty' -    go n acc_args (FunTy arg_ty res_ty)-      = ASSERT( not (isPredTy arg_ty) )+    go n acc_args (FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty })+      = ASSERT( af == VisArg )         do { (wrap_res, tys, ty_r) <- go (n-1) (arg_ty : acc_args) res_ty            ; return ( mkWpFun idHsWrapper wrap_res arg_ty ty_r doc                     , arg_ty : tys, ty_r ) }@@ -302,7 +308,7 @@        -- However unlike the meta-tyvar case, we are sure that the        -- number of arguments doesn't match arity of the original        -- type, so we can add a bit more context to the error message-       -- (cf Trac #7869).+       -- (cf #7869).        --        -- It is not always an error, because specialized type may have        -- different arity, for example:@@ -312,7 +318,7 @@        -- > f2 = undefined        --        -- But in that case we add specialized type into error context-       -- anyway, because it may be useful. See also Trac #9605.+       -- anyway, because it may be useful. See also #9605.     go n acc_args ty = addErrCtxtM (mk_ctxt (reverse acc_args) ty) $                        defer n ty @@ -320,14 +326,14 @@     defer n fun_ty       = do { arg_tys <- replicateM n newOpenFlexiTyVarTy            ; res_ty  <- newOpenFlexiTyVarTy-           ; let unif_fun_ty = mkFunTys arg_tys res_ty+           ; let unif_fun_ty = mkVisFunTys arg_tys res_ty            ; co <- unifyType mb_thing fun_ty unif_fun_ty            ; return (mkWpCastN co, arg_tys, res_ty) }      ------------     mk_ctxt :: [TcSigmaType] -> TcSigmaType -> TidyEnv -> TcM (TidyEnv, MsgDoc)     mk_ctxt arg_tys res_ty env-      = do { let ty = mkFunTys arg_tys res_ty+      = do { let ty = mkVisFunTys arg_tys res_ty            ; (env1, zonked) <- zonkTidyTcType env ty                    -- zonking might change # of args            ; let (zonked_args, _) = tcSplitFunTys zonked@@ -399,7 +405,7 @@     -- Then we don't want to instantiate T's data constructors with     --    (a::*) ~ Maybe     -- because that'll make types that are utterly ill-kinded.-    -- This happened in Trac #7368+    -- This happened in #7368     defer       = do { (_, arg_tvs) <- newMetaTyVars (tyConTyVars tc)            ; traceTc "matchExpectedTyConApp" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs)@@ -441,7 +447,7 @@            ; return (co, (ty1, ty2)) }      orig_kind = tcTypeKind orig_ty-    kind1 = mkFunTy liftedTypeKind orig_kind+    kind1 = mkVisFunTy liftedTypeKind orig_kind     kind2 = liftedTypeKind    -- m :: * -> k                               -- arg type :: * @@ -517,7 +523,7 @@ HsWrapper.  Another powerful reason for doing this co/contra stuff is visible-in Trac #9569, involving instantiation of constraint variables,+in #9569, involving instantiation of constraint variables, and again involving eta-expansion.  Wrinkle 3: Note [Higher rank types]@@ -714,7 +720,7 @@      ty_expected isn't really polymorphic  If we prematurely go to equality we'll reject a program we should-accept (e.g. Trac #13752).  So the test (which is only to improve+accept (e.g. #13752).  So the test (which is only to improve error message) is very conservative:  * ty_actual is /definitely/ monomorphic  * ty_expected is /definitely/ polymorphic@@ -751,12 +757,11 @@     -- which, in the impredicative case unified  alpha := ty_a     -- where th_a is a polytype.  Not only is this probably bogus (we     -- simply do not have decent story for impredicative types), but it-    -- caused Trac #12616 because (also bizarrely) 'deriving' code had+    -- caused #12616 because (also bizarrely) 'deriving' code had     -- -XImpredicativeTypes on.  I deleted the entire case. -    go (FunTy act_arg act_res) (FunTy exp_arg exp_res)-      | not (isPredTy act_arg)-      , not (isPredTy exp_arg)+    go (FunTy { ft_af = VisArg, ft_arg = act_arg, ft_res = act_res })+       (FunTy { ft_af = VisArg, ft_arg = exp_arg, ft_res = exp_res })       = -- See Note [Co/contra-variance of subsumption checking]         do { res_wrap <- tc_sub_type_ds eq_orig inst_orig  ctxt       act_res exp_res            ; arg_wrap <- tc_sub_tc_type eq_orig given_orig GenSigCtxt exp_arg act_arg@@ -790,7 +795,7 @@      inst_and_unify = do { (wrap, rho_a) <- deeplyInstantiate inst_orig ty_actual -                           -- if we haven't recurred through an arrow, then+                           -- If we haven't recurred through an arrow, then                            -- the eq_orig will list ty_actual. In this case,                            -- we want to update the origin to reflect the                            -- instantiation. If we *have* recurred through@@ -926,35 +931,63 @@ an InferResult, and in some cases not.  That's why InferReult has the ir_inst flag. -* ir_inst = True: deeply instantiate+ir_inst = True: deeply instantiate+---------------------------------- -  Consider+1. Consider     f x = (*)-  We want to instantiate the type of (*) before returning, else we-  will infer the type-    f :: forall {a}. a -> forall b. Num b => b -> b -> b-  This is surely confusing for users.+   We want to instantiate the type of (*) before returning, else we+   will infer the type+     f :: forall {a}. a -> forall b. Num b => b -> b -> b+   This is surely confusing for users. -  And worse, the monomorphism restriction won't work properly. The MR is-  dealt with in simplifyInfer, and simplifyInfer has no way of-  instantiating. This could perhaps be worked around, but it may be-  hard to know even when instantiation should happen.+   And worse, the monomorphism restriction won't work properly. The MR is+   dealt with in simplifyInfer, and simplifyInfer has no way of+   instantiating. This could perhaps be worked around, but it may be+   hard to know even when instantiation should happen. -  Another reason.  Consider+2. Another reason.  Consider        f :: (?x :: Int) => a -> a        g y = let ?x = 3::Int in f-  Here want to instantiate f's type so that the ?x::Int constraint-  gets discharged by the enclosing implicit-parameter binding.+   Here want to instantiate f's type so that the ?x::Int constraint+   gets discharged by the enclosing implicit-parameter binding. -* ir_inst = False: do not instantiate+ir_inst = False: do not instantiate+----------------------------------- -  Consider this (which uses visible type application):+1. Consider this (which uses visible type application):      (let { f :: forall a. a -> a; f x = x } in f) @Int -  We'll call TcExpr.tcInferFun to infer the type of the (let .. in f)-  And we don't want to instantite the type of 'f' when we reach it,-  else the outer visible type application won't work+   We'll call TcExpr.tcInferFun to infer the type of the (let .. in f)+   And we don't want to instantite the type of 'f' when we reach it,+   else the outer visible type application won't work++2. :type +v. When we say++     :type +v const @Int++   we really want `forall b. Int -> b -> Int`. Note that this is *not*+   instantiated.++3. Pattern bindings. For example:++     foo x+       | blah <- const @Int+       = (blah x False, blah x 'z')++   Note that `blah` is polymorphic. (This isn't a terribly compelling+   reason, but the choice of ir_inst does matter here.)++Discussion+----------+We thought that we should just remove the ir_inst flag, in favor of+always instantiating. Essentially: motivations (1) and (3) for ir_inst = False+are not terribly exciting. However, motivation (2) is quite important.+Furthermore, there really was not much of a simplification of the code+in removing ir_inst, and working around it to enable flows like what we+see in (2) is annoying. This was done in #17173.+ -}  {- *********************************************************************@@ -1004,7 +1037,7 @@  {- Note [Promoting a type] ~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (Trac #12427)+Consider (#12427)    data T where     MkT :: (Int -> Int) -> a -> T@@ -1176,7 +1209,13 @@                          -> TcLevel -> WantedConstraints -> TcM () emitResidualTvConstraint skol_info m_telescope skol_tvs tclvl wanted   | isEmptyWC wanted+  , isNothing m_telescope || skol_tvs `lengthAtMost` 1+    -- If m_telescope is (Just d), we must do the bad-telescope check,+    -- so we must /not/ discard the implication even if there are no+    -- wanted constraints. See Note [Checking telescopes] in Constraint.+    -- Lacking this check led to #16247   = return ()+   | otherwise   = do { ev_binds <- newNoTcEvBinds        ; implic   <- newImplication@@ -1221,7 +1260,7 @@ alwaysBuildImplication _ = False  {-  Commmented out for now while I figure out about error messages.-    See Trac #14185+    See #14185  alwaysBuildImplication (SigSkol ctxt _ _)   = case ctxt of@@ -1277,7 +1316,7 @@   top-level unlifted bindings, which are verboten. This only matters   at top level, so we check for that   See also Note [Deferred errors for coercion holes] in TcErrors.-  cf Trac #14149 for an example of what goes wrong.+  cf #14149 for an example of what goes wrong.  * If you have      f :: Int;  f = f_blah@@ -1288,7 +1327,7 @@       [W] C Int b1    -- from f_blah       [W] C Int b2    -- from g_blan   and fundpes can yield [D] b1 ~ b2, even though the two functions have-  literally nothing to do with each other.  Trac #14185 is an example.+  literally nothing to do with each other.  #14185 is an example.   Building an implication keeps them separage. -} @@ -1388,7 +1427,7 @@       = do { co_tys <- uType t_or_k origin t1 t2            ; return (mkCoherenceRightCo Nominal t2 co2 co_tys) } -        -- Variables; go for uVar+        -- Variables; go for uUnfilledVar         -- Note that we pass in *original* (before synonym expansion),         -- so that type variables tend to get filled in with         -- the most informative version of the type@@ -1417,13 +1456,13 @@         --   type Foo = Int         -- and we try to unify  Foo ~ Bool         -- we'll end up saying "can't match Foo with Bool"-        -- rather than "can't match "Int with Bool".  See Trac #4535.+        -- rather than "can't match "Int with Bool".  See #4535.     go ty1 ty2       | Just ty1' <- tcView ty1 = go ty1' ty2       | Just ty2' <- tcView ty2 = go ty1  ty2'          -- Functions (or predicate functions) just check the two parts-    go (FunTy fun1 arg1) (FunTy fun2 arg2)+    go (FunTy _ fun1 arg1) (FunTy _ fun2 arg2)       = do { co_l <- uType t_or_k origin fun1 fun2            ; co_r <- uType t_or_k origin arg1 arg2            ; return $ mkFunCo Nominal co_l co_r }@@ -1457,12 +1496,12 @@      go (AppTy s1 t1) (TyConApp tc2 ts2)       | Just (ts2', t2') <- snocView ts2-      = ASSERT( mightBeUnsaturatedTyCon tc2 )+      = ASSERT( not (mustBeSaturated tc2) )         go_app (isNextTyConArgVisible tc2 ts2') s1 t1 (TyConApp tc2 ts2') t2'      go (TyConApp tc1 ts1) (AppTy s2 t2)       | Just (ts1', t1') <- snocView ts1-      = ASSERT( mightBeUnsaturatedTyCon tc1 )+      = ASSERT( not (mustBeSaturated tc1) )         go_app (isNextTyConArgVisible tc1 ts1') (TyConApp tc1 ts1') t1' s2 t2      go (CoercionTy co1) (CoercionTy co2)@@ -1517,7 +1556,7 @@         w (T x) ~ Foo (T x y) We do match (w ~ Foo) first, but in some circumstances we simply create a deferred constraint; and then go ahead and match (T x ~ T x y).-This came up in Trac #3950.+This came up in #3950.  So either    (a) either we must check for identical argument kinds@@ -1576,11 +1615,11 @@  ************************************************************************ *                                                                      *-                 uVar and friends+                 uUnfilledVar and friends *                                                                      * ************************************************************************ -@uVar@ is called when at least one of the types being unified is a+@uunfilledVar@ is called when at least one of the types being unified is a variable.  It does {\em not} assume that the variable is a fixed point of the substitution; rather, notice that @uVar@ (defined below) nips back into @uTys@ if it turns out that the variable is already bound.@@ -1590,7 +1629,8 @@ uUnfilledVar :: CtOrigin              -> TypeOrKind              -> SwapFlag-             -> TcTyVar        -- Tyvar 1+             -> TcTyVar        -- Tyvar 1: not necessarily a meta-tyvar+                               --    definitely not a /filled/ meta-tyvar              -> TcTauType      -- Type 2              -> TcM Coercion -- "Unfilled" means that the variable is definitely not a filled-in meta tyvar@@ -1608,7 +1648,8 @@ uUnfilledVar1 :: CtOrigin               -> TypeOrKind               -> SwapFlag-              -> TcTyVar        -- Tyvar 1+              -> TcTyVar        -- Tyvar 1: not necessarily a meta-tyvar+                                --    definitely not a /filled/ meta-tyvar               -> TcTauType      -- Type 2, zonked               -> TcM Coercion uUnfilledVar1 origin t_or_k swapped tv1 ty2@@ -1621,12 +1662,19 @@   where     -- 'go' handles the case where both are     -- tyvars so we might want to swap+    -- E.g. maybe tv2 is a meta-tyvar and tv1 is not     go tv2 | tv1 == tv2  -- Same type variable => no-op            = return (mkNomReflCo (mkTyVarTy tv1))             | swapOverTyVars tv1 tv2   -- Distinct type variables-           = uUnfilledVar2 origin t_or_k (flipSwap swapped)-                           tv2 (mkTyVarTy tv1)+               -- Swap meta tyvar to the left if poss+           = do { tv1 <- zonkTyCoVarKind tv1+                     -- We must zonk tv1's kind because that might+                     -- not have happened yet, and it's an invariant of+                     -- uUnfilledTyVar2 that ty2 is fully zonked+                     -- Omitting this caused #16902+                ; uUnfilledVar2 origin t_or_k (flipSwap swapped)+                           tv2 (mkTyVarTy tv1) }             | otherwise            = uUnfilledVar2 origin t_or_k swapped tv1 ty2@@ -1635,7 +1683,8 @@ uUnfilledVar2 :: CtOrigin               -> TypeOrKind               -> SwapFlag-              -> TcTyVar        -- Tyvar 1+              -> TcTyVar        -- Tyvar 1: not necessarily a meta-tyvar+                                --    definitely not a /filled/ meta-tyvar               -> TcTauType      -- Type 2, zonked               -> TcM Coercion uUnfilledVar2 origin t_or_k swapped tv1 ty2@@ -1652,8 +1701,10 @@                   , ppr ty2 <+> dcolon <+> ppr (tcTypeKind  ty2)                   , ppr (isTcReflCo co_k), ppr co_k ] -           ; if isTcReflCo co_k  -- only proceed if the kinds matched.-+           ; if isTcReflCo co_k+               -- Only proceed if the kinds match+               -- NB: tv1 should still be unfilled, despite the kind unification+               --     because tv1 is not free in ty2 (or, hence, in its kind)              then do { writeMetaTyVar tv1 ty2'                      ; return (mkTcNomReflCo ty2') } @@ -1776,7 +1827,7 @@   skolems, so it's important that skolems have (accurate) level   numbers. -See Trac #15009 for an further analysis of why "deepest on the left"+See #15009 for an further analysis of why "deepest on the left" is a good plan.  Note [Fmv Orientation Invariant]@@ -1832,7 +1883,7 @@ and then replace all uses of 'a' with fsk.  That's bad because in error messages instead of saying 'a' we'll say (F [a]).  In all places, including those where the programmer wrote 'a' in the first-place.  Very confusing!  See Trac #7862.+place.  Very confusing!  See #7862.  Solution: re-orient a~fsk to fsk~a, so that we preferentially eliminate the fsk.@@ -1860,7 +1911,7 @@ into kicking out and rewriting inert constraints.  This is a performance optimisation only.  It turns out to fix-Trac #14723 all by itself, but clearly not reliably so!+#14723 all by itself, but clearly not reliably so!  It's simple to implement (see nicer_to_update_tv2 in swapOverTyVars). But, to my surprise, it didn't seem to make any significant difference@@ -2026,37 +2077,43 @@ -}  -- | Breaks apart a function kind into its pieces.-matchExpectedFunKind :: Outputable fun-                     => fun             -- ^ type, only for errors-                     -> TcKind          -- ^ function kind-                     -> TcM (Coercion, TcKind, TcKind)-                                  -- ^ co :: old_kind ~ arg -> res-matchExpectedFunKind hs_ty = go+matchExpectedFunKind+  :: Outputable fun+  => fun             -- ^ type, only for errors+  -> Arity           -- ^ n: number of desired arrows+  -> TcKind          -- ^ fun_ kind+  -> TcM Coercion    -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res)++matchExpectedFunKind hs_ty n k = go n k   where-    go k | Just k' <- tcView k = go k'+    go 0 k = return (mkNomReflCo k) -    go k@(TyVarTy kvar)+    go n k | Just k' <- tcView k = go n k'++    go n k@(TyVarTy kvar)       | isMetaTyVar kvar       = do { maybe_kind <- readMetaTyVar kvar            ; case maybe_kind of-                Indirect fun_kind -> go fun_kind-                Flexi ->             defer k }+                Indirect fun_kind -> go n fun_kind+                Flexi ->             defer n k } -    go k@(FunTy arg res) = return (mkNomReflCo k, arg, res)-    go other             = defer other+    go n (FunTy _ arg res)+      = do { co <- go (n-1) res+           ; return (mkTcFunCo Nominal (mkTcNomReflCo arg) co) } -    defer k-      = do { arg_kind <- newMetaKindVar-           ; res_kind <- newMetaKindVar-           ; let new_fun = mkFunTy arg_kind res_kind+    go n other+     = defer n other++    defer n k+      = do { arg_kinds <- newMetaKindVars n+           ; res_kind  <- newMetaKindVar+           ; let new_fun = mkVisFunTys arg_kinds res_kind                  origin  = TypeEqOrigin { uo_actual   = k                                         , uo_expected = new_fun                                         , uo_thing    = Just (ppr hs_ty)                                         , uo_visible  = True                                         }-           ; co <- uType KindLevel origin k new_fun-           ; return (co, arg_kind, res_kind) }-+           ; uType KindLevel origin k new_fun }  {- ********************************************************************* *                                                                      *@@ -2110,43 +2167,41 @@  -} -data OccCheckResult a-  = OC_OK a-  | OC_Bad     -- Forall or type family-  | OC_Occurs--instance Functor OccCheckResult where-      fmap = liftM+data MetaTyVarUpdateResult a+  = MTVU_OK a+  | MTVU_Bad     -- Forall, predicate, or type family+  | MTVU_Occurs+    deriving (Functor) -instance Applicative OccCheckResult where-      pure = OC_OK+instance Applicative MetaTyVarUpdateResult where+      pure = MTVU_OK       (<*>) = ap -instance Monad OccCheckResult where-  OC_OK x    >>= k = k x-  OC_Bad     >>= _ = OC_Bad-  OC_Occurs  >>= _ = OC_Occurs+instance Monad MetaTyVarUpdateResult where+  MTVU_OK x    >>= k = k x+  MTVU_Bad     >>= _ = MTVU_Bad+  MTVU_Occurs  >>= _ = MTVU_Occurs -occCheckForErrors :: DynFlags -> TcTyVar -> Type -> OccCheckResult ()--- Just for error-message generation; so we return OccCheckResult+occCheckForErrors :: DynFlags -> TcTyVar -> Type -> MetaTyVarUpdateResult ()+-- Just for error-message generation; so we return MetaTyVarUpdateResult -- so the caller can report the right kind of error -- Check whether --   a) the given variable occurs in the given type. --   b) there is a forall in the type (unless we have -XImpredicativeTypes) occCheckForErrors dflags tv ty   = case preCheck dflags True tv ty of-      OC_OK _   -> OC_OK ()-      OC_Bad    -> OC_Bad-      OC_Occurs -> case occCheckExpand [tv] ty of-                     Nothing -> OC_Occurs-                     Just _  -> OC_OK ()+      MTVU_OK _   -> MTVU_OK ()+      MTVU_Bad    -> MTVU_Bad+      MTVU_Occurs -> case occCheckExpand [tv] ty of+                       Nothing -> MTVU_Occurs+                       Just _  -> MTVU_OK ()  ---------------- metaTyVarUpdateOK :: DynFlags                   -> TcTyVar             -- tv :: k1                   -> TcType              -- ty :: k2                   -> Maybe TcType        -- possibly-expanded ty--- (metaTyFVarUpdateOK tv ty)+-- (metaTyVarUpdateOK tv ty) -- We are about to update the meta-tyvar tv with ty -- Check (a) that tv doesn't occur in ty (occurs check) --       (b) that ty does not have any foralls@@ -2173,17 +2228,18 @@   = case preCheck dflags False tv ty of          -- False <=> type families not ok          -- See Note [Prevent unification with type families]-      OC_OK _   -> Just ty-      OC_Bad    -> Nothing  -- forall or type function-      OC_Occurs -> occCheckExpand [tv] ty+      MTVU_OK _   -> Just ty+      MTVU_Bad    -> Nothing  -- forall, predicate, or type function+      MTVU_Occurs -> occCheckExpand [tv] ty -preCheck :: DynFlags -> Bool -> TcTyVar -> TcType -> OccCheckResult ()+preCheck :: DynFlags -> Bool -> TcTyVar -> TcType -> MetaTyVarUpdateResult () -- A quick check for---   (a) a forall type (unless -XImpredivativeTypes)---   (b) a type family---   (c) an occurrence of the type variable (occurs check)+--   (a) a forall type (unless -XImpredicativeTypes)+--   (b) a predicate type (unless -XImpredicativeTypes)+--   (c) a type family+--   (d) an occurrence of the type variable (occurs check) ----- For (a) and (b) we check only the top level of the type, NOT+-- For (a), (b), and (c) we check only the top level of the type, NOT -- inside the kinds of variables it mentions.  But for (c) we do -- look in the kinds of course. @@ -2193,25 +2249,28 @@     details          = tcTyVarDetails tv     impredicative_ok = canUnifyWithPolyType dflags details -    ok :: OccCheckResult ()-    ok = OC_OK ()+    ok :: MetaTyVarUpdateResult ()+    ok = MTVU_OK () -    fast_check :: TcType -> OccCheckResult ()+    fast_check :: TcType -> MetaTyVarUpdateResult ()     fast_check (TyVarTy tv')-      | tv == tv' = OC_Occurs+      | tv == tv' = MTVU_Occurs       | otherwise = fast_check_occ (tyVarKind tv')            -- See Note [Occurrence checking: look inside kinds]      fast_check (TyConApp tc tys)-      | bad_tc tc              = OC_Bad+      | bad_tc tc              = MTVU_Bad       | otherwise              = mapM fast_check tys >> ok     fast_check (LitTy {})      = ok-    fast_check (FunTy a r)     = fast_check a   >> fast_check r+    fast_check (FunTy{ft_af = af, ft_arg = a, ft_res = r})+      | InvisArg <- af+      , not impredicative_ok   = MTVU_Bad+      | otherwise              = fast_check a   >> fast_check r     fast_check (AppTy fun arg) = fast_check fun >> fast_check arg     fast_check (CastTy ty co)  = fast_check ty  >> fast_check_co co     fast_check (CoercionTy co) = fast_check_co co     fast_check (ForAllTy (Bndr tv' _) ty)-       | not impredicative_ok = OC_Bad+       | not impredicative_ok = MTVU_Bad        | tv == tv'            = ok        | otherwise = do { fast_check_occ (tyVarKind tv')                         ; fast_check_occ ty }@@ -2221,13 +2280,13 @@      -- For kinds, we only do an occurs check; we do not worry      -- about type families or foralls      -- See Note [Checking for foralls]-    fast_check_occ k | tv `elemVarSet` tyCoVarsOfType k = OC_Occurs+    fast_check_occ k | tv `elemVarSet` tyCoVarsOfType k = MTVU_Occurs                      | otherwise                        = ok       -- For coercions, we are only doing an occurs check here;      -- no bother about impredicativity in coercions, as they're      -- inferred-    fast_check_co co | tv `elemVarSet` tyCoVarsOfCo co = OC_Occurs+    fast_check_co co | tv `elemVarSet` tyCoVarsOfCo co = MTVU_Occurs                      | otherwise                       = ok      bad_tc :: TyCon -> Bool
compiler/typecheck/TcUnify.hs-boot view
@@ -1,12 +1,12 @@ module TcUnify where  import GhcPrelude-import TcType      ( TcTauType )-import TcRnTypes   ( TcM )-import TcEvidence  ( TcCoercion )-import HsExpr      ( HsExpr )-import HsTypes     ( HsType )-import HsExtension ( GhcRn )+import TcType           ( TcTauType )+import TcRnTypes        ( TcM )+import TcEvidence       ( TcCoercion )+import GHC.Hs.Expr      ( HsExpr )+import GHC.Hs.Types     ( HsType )+import GHC.Hs.Extension ( GhcRn )  -- This boot file exists only to tie the knot between --              TcUnify and Inst
compiler/typecheck/TcValidity.hs view
@@ -13,11 +13,11 @@   checkValidCoAxiom, checkValidCoAxBranch,   checkValidTyFamEqn, checkConsistentFamInst,   badATErr, arityErr,-  checkValidTelescope,+  checkTyConTelescope,   allDistinctTyVars   ) where -#include "GhclibHsVersions.h"+#include "HsVersions.h"  import GhcPrelude @@ -27,7 +27,9 @@ import TcUnify    ( tcSubType_NC ) import TcSimplify ( simplifyAmbiguityCheck ) import ClsInst    ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) )+import TyCoFVs import TyCoRep+import TyCoPpr import TcType hiding ( sizeType, sizeTypes ) import TysWiredIn ( heqTyConName, eqTyConName, coercibleTyConName ) import PrelNames@@ -37,22 +39,23 @@ import CoAxiom import Class import TyCon+import Predicate+import TcOrigin  -- others: import IfaceType( pprIfaceType, pprIfaceTypeApp )-import ToIface( toIfaceType, toIfaceTyCon, toIfaceTcArgs )-import HsSyn            -- HsType+import ToIface  ( toIfaceTyCon, toIfaceTcArgs, toIfaceType )+import GHC.Hs           -- HsType import TcRnMonad        -- TcType, amongst others import TcEnv       ( tcInitTidyEnv, tcInitOpenTidyEnv ) import FunDeps import FamInstEnv  ( isDominatedBy, injectiveBranches,                      InjectivityCheckResult(..) )-import FamInst     ( makeInjectivityErrors )+import FamInst import Name import VarEnv import VarSet import Var         ( VarBndr(..), mkTyVar )-import Id          ( idType, idName ) import FV import ErrUtils import DynFlags@@ -157,7 +160,7 @@   * If we try to check for ambiguity of a nested forall like     (forall a. Eq a => b), the implication constraint doesn't bind     all the skolems, which results in "No skolem info" in error-    messages (see Trac #10432).+    messages (see #10432).  To avoid this, we call checkAmbiguity once, at the top, in checkValidType. (I'm still a bit worried about unbound skolems when the type mentions@@ -231,13 +234,14 @@       GhciCtxt {}  -> False       TySynCtxt {} -> False       TypeAppCtxt  -> False+      StandaloneKindSigCtxt{} -> False       _            -> True  checkUserTypeError :: Type -> TcM () -- Check to see if the type signature mentions "TypeError blah" -- anywhere in it, and fail if so. ----- Very unsatisfactorily (Trac #11144) we need to tidy the type+-- Very unsatisfactorily (#11144) we need to tidy the type -- because it may have come from an /inferred/ signature, not a -- user-supplied one.  This is really only a half-baked fix; -- the other errors in checkValidType don't do tidying, and so@@ -269,7 +273,7 @@   It may be that when we /use/ T, we'll give an 'a' or 'b' that somehow   cure the ambiguity.  So we defer the ambiguity check to the use site. -  There is also an implementation reason (Trac #11608).  In the RHS of+  There is also an implementation reason (#11608).  In the RHS of   a type synonym we don't (currently) instantiate 'a' and 'b' with   TcTyVars before calling checkValidType, so we get asertion failures   from doing an ambiguity check on a type with TyVars in it.  Fixing this@@ -279,6 +283,10 @@      f @ty   No need to check ty for ambiguity +* StandaloneKindSigCtxt: type T :: ksig+  Kinds need a different ambiguity check than types, and the currently+  implemented check is only good for types. See #14419, in particular+  https://gitlab.haskell.org/ghc/ghc/issues/14419#note_160844  ************************************************************************ *                                                                      *@@ -342,6 +350,7 @@                   ExprSigCtxt    -> rank1                  KindSigCtxt    -> rank1+                 StandaloneKindSigCtxt{} -> rank1                  TypeAppCtxt | impred_flag -> ArbitraryRank                              | otherwise   -> tyConArgMonoType                     -- Normally, ImpredicativeTypes is handled in check_arg_type,@@ -349,7 +358,9 @@                     -- So we do this check here.                   FunSigCtxt {}  -> rank1-                 InfSigCtxt _   -> ArbitraryRank        -- Inferred type+                 InfSigCtxt {}  -> rank1 -- Inferred types should obey the+                                         -- same rules as declared ones+                  ConArgCtxt _   -> rank1 -- We are given the type of the entire                                          -- constructor, hence rank 1                  PatSynCtxt _   -> rank1@@ -417,7 +428,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~ Technically             Int -> forall a. a->a-is still a rank-1 type, but it's not Haskell 98 (Trac #5957).  So the+is still a rank-1 type, but it's not Haskell 98 (#5957).  So the validity checker allow a forall after an arrow only if we allow it before -- that is, with Rank2Types or RankNTypes -}@@ -456,14 +467,65 @@ forAllAllowed (LimitedRank forall_ok _) = forall_ok forAllAllowed _                         = False -constraintsAllowed :: UserTypeCtxt -> Bool--- We don't allow constraints in kinds-constraintsAllowed (TyVarBndrKindCtxt {}) = False-constraintsAllowed (DataKindCtxt {})      = False-constraintsAllowed (TySynKindCtxt {})     = False-constraintsAllowed (TyFamResKindCtxt {})  = False-constraintsAllowed _ = True+allConstraintsAllowed :: UserTypeCtxt -> Bool+-- We don't allow arbitrary constraints in kinds+allConstraintsAllowed (TyVarBndrKindCtxt {}) = False+allConstraintsAllowed (DataKindCtxt {})      = False+allConstraintsAllowed (TySynKindCtxt {})     = False+allConstraintsAllowed (TyFamResKindCtxt {})  = False+allConstraintsAllowed (StandaloneKindSigCtxt {}) = False+allConstraintsAllowed _ = True +-- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the+-- context for the type of a term, where visible, dependent quantification is+-- currently disallowed.+--+-- An example of something that is unambiguously the type of a term is the+-- @forall a -> a -> a@ in @foo :: forall a -> a -> a@. On the other hand, the+-- same type in @type family Foo :: forall a -> a -> a@ is unambiguously the+-- kind of a type, not the type of a term, so it is permitted.+--+-- For more examples, see+-- @testsuite/tests/dependent/should_compile/T16326_Compile*.hs@ (for places+-- where VDQ is permitted) and+-- @testsuite/tests/dependent/should_fail/T16326_Fail*.hs@ (for places where+-- VDQ is disallowed).+vdqAllowed :: UserTypeCtxt -> Bool+-- Currently allowed in the kinds of types...+vdqAllowed (KindSigCtxt {}) = True+vdqAllowed (StandaloneKindSigCtxt {}) = True+vdqAllowed (TySynCtxt {}) = True+vdqAllowed (ThBrackCtxt {}) = True+vdqAllowed (GhciCtxt {}) = True+vdqAllowed (TyVarBndrKindCtxt {}) = True+vdqAllowed (DataKindCtxt {}) = True+vdqAllowed (TySynKindCtxt {}) = True+vdqAllowed (TyFamResKindCtxt {}) = True+-- ...but not in the types of terms.+vdqAllowed (ConArgCtxt {}) = False+  -- We could envision allowing VDQ in data constructor types so long as the+  -- constructor is only ever used at the type level, but for now, GHC adopts+  -- the stance that VDQ is never allowed in data constructor types.+vdqAllowed (FunSigCtxt {}) = False+vdqAllowed (InfSigCtxt {}) = False+vdqAllowed (ExprSigCtxt {}) = False+vdqAllowed (TypeAppCtxt {}) = False+vdqAllowed (PatSynCtxt {}) = False+vdqAllowed (PatSigCtxt {}) = False+vdqAllowed (RuleSigCtxt {}) = False+vdqAllowed (ResSigCtxt {}) = False+vdqAllowed (ForSigCtxt {}) = False+vdqAllowed (DefaultDeclCtxt {}) = False+-- We count class constraints as "types of terms". All of the cases below deal+-- with class constraints.+vdqAllowed (InstDeclCtxt {}) = False+vdqAllowed (SpecInstCtxt {}) = False+vdqAllowed (GenSigCtxt {}) = False+vdqAllowed (ClassSCCtxt {}) = False+vdqAllowed (SigmaCtxt {}) = False+vdqAllowed (DataTyCtxt {}) = False+vdqAllowed (DerivClauseCtxt {}) = False+ {- Note [Correctness and performance of type synonym validity checking] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -500,7 +562,7 @@   If we expand `Bar Foo` immediately, we'll miss the fact that the `Foo` type   synonyms is unsaturated. * If one never expands and only checks the arguments, then one can miss-  erroneous programs like the one in Trac #16059:+  erroneous programs like the one in #16059:      type Foo b = Eq b => b     f :: forall b (a :: Foo b). Int@@ -618,16 +680,21 @@ check_type ve@(ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt                           , ve_rank = rank, ve_expand = expand }) ty   | not (null tvbs && null theta)-  = do  { traceTc "check_type" (ppr ty $$ ppr (forAllAllowed rank))+  = do  { traceTc "check_type" (ppr ty $$ ppr rank)         ; checkTcM (forAllAllowed rank) (forAllTyErr env rank ty)                 -- Reject e.g. (Maybe (?x::Int => Int)),                 -- with a decent error message -        ; checkTcM (null theta || constraintsAllowed ctxt)-                   (constraintTyErr env ty)+        ; checkConstraintsOK ve theta ty                 -- Reject forall (a :: Eq b => b). blah                 -- In a kind signature we don't allow constraints +        ; checkTcM (all (isInvisibleArgFlag . binderArgFlag) tvbs+                         || vdqAllowed ctxt)+                   (illegalVDQTyErr env ty)+                -- Reject visible, dependent quantification in the type of a+                -- term (e.g., `f :: forall a -> a -> Maybe a`)+         ; check_valid_theta env' SigmaCtxt expand theta                 -- Allow     type T = ?x::Int => Int -> Int                 -- but not   type T = ?x::Int@@ -635,22 +702,13 @@         ; check_type (ve{ve_tidy_env = env'}) tau                 -- Allow foralls to right of arrow -        ; checkTcM (not (any (`elemVarSet` tyCoVarsOfType phi_kind) tvs))-                   (forAllEscapeErr env' ty tau_kind)-        }+        ; checkEscapingKind env' tvbs' theta tau }   where-    (tvbs, phi)  = tcSplitForAllVarBndrs ty-    (theta, tau) = tcSplitPhiTy phi--    tvs          = binderVars tvbs-    (env', _)    = tidyVarBndrs env tvs--    tau_kind              = tcTypeKind tau-    phi_kind | null theta = tau_kind-             | otherwise  = liftedTypeKind-        -- If there are any constraints, the kind is *. (#11405)+    (tvbs, phi)   = tcSplitForAllVarBndrs ty+    (theta, tau)  = tcSplitPhiTy phi+    (env', tvbs') = tidyTyCoVarBinders env tvbs -check_type (ve@ValidityEnv{ve_rank = rank}) (FunTy arg_ty res_ty)+check_type (ve@ValidityEnv{ve_rank = rank}) (FunTy _ arg_ty res_ty)   = do  { check_type (ve{ve_rank = arg_rank}) arg_ty         ; check_type (ve{ve_rank = res_rank}) res_ty }   where@@ -698,11 +756,12 @@      check_args_only, check_expansion_only :: ExpandMode -> TcM ()     check_args_only expand = mapM_ (check_arg expand) tys-    check_expansion_only expand =-      case tcView ty of-         Just ty' -> let syn_tc = fst $ tcRepSplitTyConApp ty-                         err_ctxt = text "In the expansion of type synonym"-                                    <+> quotes (ppr syn_tc)++    check_expansion_only expand+      = ASSERT2( isTypeSynonymTyCon tc, ppr tc )+        case tcView ty of+         Just ty' -> let err_ctxt = text "In the expansion of type synonym"+                                    <+> quotes (ppr tc)                      in addErrCtxt err_ctxt $                         check_type (ve{ve_expand = expand}) ty'          Nothing  -> pprPanic "check_syn_tc_app" (ppr ty)@@ -822,24 +881,82 @@                    MonoType d     -> d                    _              -> Outputable.empty -- Polytype is always illegal -forAllEscapeErr :: TidyEnv -> Type -> Kind -> (TidyEnv, SDoc)-forAllEscapeErr env ty tau_kind+-- | Reject type variables that would escape their escape through a kind.+-- See @Note [Type variables escaping through kinds]@.+checkEscapingKind :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> TcM ()+checkEscapingKind env tvbs theta tau =+  case occCheckExpand (binderVars tvbs) phi_kind of+    -- Ensure that none of the tvs occur in the kind of the forall+    -- /after/ expanding type synonyms.+    -- See Note [Phantom type variables in kinds] in Type+    Nothing -> failWithTcM $ forAllEscapeErr env tvbs theta tau tau_kind+    Just _  -> pure ()+  where+    tau_kind              = tcTypeKind tau+    phi_kind | null theta = tau_kind+             | otherwise  = liftedTypeKind+        -- If there are any constraints, the kind is *. (#11405)++forAllEscapeErr :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> Kind+                -> (TidyEnv, SDoc)+forAllEscapeErr env tvbs theta tau tau_kind   = ( env-    , hang (vcat [ text "Quantified type's kind mentions quantified type variable"-                 , text "(skolem escape)" ])-         2 (vcat [ text "   type:" <+> ppr_tidy env ty-                 , text "of kind:" <+> ppr_tidy env tau_kind ]) )+    , vcat [ hang (text "Quantified type's kind mentions quantified type variable")+                2 (text "type:" <+> quotes (ppr (mkSigmaTy tvbs theta tau)))+                -- NB: Don't tidy this type since the tvbs were already tidied+                -- previously, and re-tidying them will make the names of type+                -- variables different from tau_kind.+           , hang (text "where the body of the forall has this kind:")+                2 (quotes (ppr_tidy env tau_kind)) ] ) +{-+Note [Type variables escaping through kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:++  type family T (r :: RuntimeRep) :: TYPE r+  foo :: forall r. T r++Something smells funny about the type of `foo`. If you spell out the kind+explicitly, it becomes clearer from where the smell originates:++  foo :: ((forall r. T r) :: TYPE r)++The type variable `r` appears in the result kind, which escapes the scope of+its binding site! This is not desirable, so we establish a validity check+(`checkEscapingKind`) to catch any type variables that might escape through+kinds in this way.+-}+ ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) ubxArgTyErr env ty   = ( env, vcat [ sep [ text "Illegal unboxed tuple type as function argument:"                       , ppr_tidy env ty ]                 , text "Perhaps you intended to use UnboxedTuples" ] ) +checkConstraintsOK :: ValidityEnv -> ThetaType -> Type -> TcM ()+checkConstraintsOK ve theta ty+  | null theta                         = return ()+  | allConstraintsAllowed (ve_ctxt ve) = return ()+  | otherwise+  = -- We are in a kind, where we allow only equality predicates+    -- See Note [Constraints in kinds] in TyCoRep, and #16263+    checkTcM (all isEqPred theta) $+    constraintTyErr (ve_tidy_env ve) ty+ constraintTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) constraintTyErr env ty   = (env, text "Illegal constraint in a kind:" <+> ppr_tidy env ty) +-- | Reject a use of visible, dependent quantification in the type of a term.+illegalVDQTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)+illegalVDQTyErr env ty =+  (env, vcat+  [ hang (text "Illegal visible, dependent quantification" <+>+          text "in the type of a term:")+       2 (ppr_tidy env ty)+  , text "(GHC does not yet support this)" ] )+ {- Note [Liberal type synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -911,7 +1028,7 @@      (e :: (?x::Int) => t) it would be unclear how to discharge all the potential uses of the ?x in e.  For example, a constraint Foo [Int] might come out of e, and-applying the instance decl would show up two uses of ?x.  Trac #8912.+applying the instance decl would show up two uses of ?x.  #8912. -}  checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM ()@@ -951,7 +1068,7 @@  But we record, in 'under_syn', whether we have looked under a synonym to avoid requiring language extensions at the use site.  Main example-(Trac #9838):+(#9838):     {-# LANGUAGE ConstraintKinds #-}    module A where@@ -989,7 +1106,7 @@                 -> PredType -> TcM () check_pred_help under_syn env dflags ctxt pred   | Just pred' <- tcView pred  -- Switch on under_syn when going under a-                                 -- synonym (Trac #9838, yuk)+                                 -- synonym (#9838, yuk)   = check_pred_help True env dflags ctxt pred'    | otherwise  -- A bit like classifyPredType, but not the same@@ -1054,7 +1171,7 @@   = do { -- If it looks like (x t1 t2), require ConstraintKinds          --   see Note [ConstraintKinds in predicates]          -- But (X t1 t2) is always ok because we just require ConstraintKinds-         -- at the definition site (Trac #9838)+         -- at the definition site (#9838)         failIfTcM (not under_syn && not (xopt LangExt.ConstraintKinds dflags)                                 && hasTyVarHead pred)                   (predIrredErr env pred)@@ -1075,7 +1192,7 @@ {- Note [ConstraintKinds in predicates] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Don't check for -XConstraintKinds under a type synonym, because that-was done at the type synonym definition site; see Trac #9838+was done at the type synonym definition site; see #9838 e.g.   module A where           type C a = (Eq a, Ix a)   -- Needs -XConstraintKinds        module B where@@ -1099,8 +1216,8 @@ check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt                  -> PredType -> Class -> [TcType] -> TcM () check_class_pred env dflags ctxt pred cls tys-  |  cls `hasKey` heqTyConKey   -- (~) and (~~) are classified as classes,-  || cls `hasKey` eqTyConKey    -- but here we want to treat them as equalities+  |  isEqPredClass cls    -- (~) and (~~) are classified as classes,+                          -- but here we want to treat them as equalities   = -- pprTrace "check_class" (ppr cls) $     check_eq_pred env dflags pred @@ -1157,17 +1274,10 @@     simplifiable_constraint_warn what      = vcat [ hang (text "The constraint" <+> quotes (ppr (tidyType env pred))                     <+> text "matches")-                 2 (ppr_what what)+                 2 (ppr what)             , hang (text "This makes type inference for inner bindings fragile;")                  2 (text "either use MonoLocalBinds, or simplify it using the instance") ] -    ppr_what BuiltinInstance = text "a built-in instance"-    ppr_what LocalInstance   = text "a locally-quantified instance"-    ppr_what (TopLevInstance { iw_dfun_id = dfun })-      = hang (text "instance" <+> pprSigmaType (idType dfun))-           2 (text "--" <+> pprDefinedAt (idName dfun))-- {- Note [Simplifiable given constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A type signature like@@ -1177,7 +1287,7 @@ most part the clever stuff in TcInteract means that we don't use a top-level instance if a local Given might fire, so there is no fragility. But if we /infer/ the type of a local let-binding, things-can go wrong (Trac #11948 is an example, discussed in the Note).+can go wrong (#11948 is an example, discussed in the Note).  So this warning is switched on only if we have NoMonoLocalBinds; in that case the warning discourages users from writing simplifiable@@ -1187,7 +1297,7 @@ matches the top-level instances in only one way, and with no unifiers -- that is, under the same circumstances that TcInteract.matchInstEnv fires an interaction with the top-level instances.  For example (Trac #13526), consider+level instances.  For example (#13526), consider    instance {-# OVERLAPPABLE #-} Eq (T a) where ...   instance                   Eq (T Char) where ..@@ -1221,9 +1331,10 @@ okIPCtxt (DataTyCtxt {})        = True okIPCtxt (PatSynCtxt {})        = True okIPCtxt (TySynCtxt {})         = True   -- e.g.   type Blah = ?x::Int-                                         -- Trac #11466+                                         -- #11466  okIPCtxt (KindSigCtxt {})       = False+okIPCtxt (StandaloneKindSigCtxt {}) = False okIPCtxt (ClassSCCtxt {})       = False okIPCtxt (InstDeclCtxt {})      = False okIPCtxt (SpecInstCtxt {})      = False@@ -1316,7 +1427,7 @@ -- For type-constructor arity errors, be careful to report -- the number of /visible/ arguments required and supplied, -- ignoring the /invisible/ arguments, which the user does not see.--- (e.g. Trac #10516)+-- (e.g. #10516) tyConArityErr tc tks   = arityErr (ppr (tyConFlavour tc)) (tyConName tc)              tc_type_arity tc_type_args@@ -1381,7 +1492,7 @@  That says that any module satisfying M.hsig must provide a KnownNat instance for T.  We absolultely need that instance when compiling a-module that imports M.hsig: see Trac #15379 and+module that imports M.hsig: see #15379 and Note [Fabricating Evidence for Literals in Backpack] in ClsInst.  Hence, checkValidInstHead accepts a user-written instance declaration@@ -1529,7 +1640,7 @@ tcInstHeadTyAppAllTyVars ty   | Just (tc, tys) <- tcSplitTyConApp_maybe (dropCasts ty)   = ok (filterOutInvisibleTypes tc tys)  -- avoid kinds-  | LitTy _ <- ty = True  -- accept type literals (Trac #13833)+  | LitTy _ <- ty = True  -- accept type literals (#13833)   | otherwise   = False   where@@ -1544,12 +1655,12 @@ -- This function can turn a well-kinded type into an ill-kinded -- one, so I've kept it local to this module -- To consider: drop only HoleCo casts-dropCasts (CastTy ty _)     = dropCasts ty-dropCasts (AppTy t1 t2)     = mkAppTy (dropCasts t1) (dropCasts t2)-dropCasts (FunTy t1 t2)     = mkFunTy (dropCasts t1) (dropCasts t2)-dropCasts (TyConApp tc tys) = mkTyConApp tc (map dropCasts tys)-dropCasts (ForAllTy b ty)   = ForAllTy (dropCastsB b) (dropCasts ty)-dropCasts ty                = ty  -- LitTy, TyVarTy, CoercionTy+dropCasts (CastTy ty _)       = dropCasts ty+dropCasts (AppTy t1 t2)       = mkAppTy (dropCasts t1) (dropCasts t2)+dropCasts ty@(FunTy _ t1 t2)  = ty { ft_arg = dropCasts t1, ft_res = dropCasts t2 }+dropCasts (TyConApp tc tys)   = mkTyConApp tc (map dropCasts tys)+dropCasts (ForAllTy b ty)     = ForAllTy (dropCastsB b) (dropCasts ty)+dropCasts ty                  = ty  -- LitTy, TyVarTy, CoercionTy  dropCastsB :: TyVarBinder -> TyVarBinder dropCastsB b = b   -- Don't bother in the kind of a forall@@ -1639,7 +1750,7 @@        newtype T (c :: * -> * -> *) a b = MkT (c a b)        instance Category c => Category (T c) where ...     since the first argument to Category is a non-visible *, which sizeTypes-    would count as a constructor! See Trac #11833.+    would count as a constructor! See #11833.    * Also check for a bizarre corner case, when the derived instance decl     would look like@@ -1647,7 +1758,7 @@     Note that 'b' isn't a parameter of T.  This gives rise to all sorts of     problems; in particular, it's hard to compare solutions for equality     when finding the fixpoint, and that means the inferContext loop does-    not converge.  See Trac #5287.+    not converge.  See #5287.  Note [Equality class instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1687,7 +1798,7 @@ {- Note [Instances and constraint synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Currently, we don't allow instances for constraint synonyms at all.-Consider these (Trac #13267):+Consider these (#13267):   type C1 a = Show (a -> Bool)   instance C1 Int where    -- I1     show _ = "ur"@@ -1798,13 +1909,13 @@    check :: VarSet -> PredType -> TcM ()    check foralld_tvs pred      = case classifyPredType pred of-         EqPred {}    -> return ()  -- See Trac #4200.+         EqPred {}    -> return ()  -- See #4200.          IrredPred {} -> check2 foralld_tvs pred (sizeType pred)          ClassPred cls tys            | isTerminatingClass cls            -> return () -           | isCTupleClass cls  -- Look inside tuple predicates; Trac #8359+           | isCTupleClass cls  -- Look inside tuple predicates; #8359            -> check_preds foralld_tvs tys             | otherwise          -- Other ClassPreds@@ -1862,7 +1973,7 @@ No: the type family in the instance head might blow up to an arbitrarily large type, depending on how 'a' is instantiated. So we require UndecidableInstances if we have a type family-in the instance head.  Trac #15172.+in the instance head.  #15172.  Note [Invisible arguments and termination] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1875,7 +1986,7 @@  I think both will ensure termination, provided we are consistent. Currently we are /not/ consistent, which is really a bug.  It's-described in Trac #15177, which contains a number of examples.+described in #15177, which contains a number of examples. The suspicious bits are the calls to filterOutInvisibleTypes. -} @@ -1917,17 +2028,19 @@      -- See Note [Verifying injectivity annotation] in FamInstEnv     check_injectivity prev_branches cur_branch       | Injective inj <- injectivity-      = do { let conflicts =+      = do { dflags <- getDynFlags+           ; let conflicts =                      fst $ foldl' (gather_conflicts inj prev_branches cur_branch)                                  ([], 0) prev_branches-           ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err)-                   (makeInjectivityErrors ax cur_branch inj conflicts) }+           ; reportConflictingInjectivityErrs fam_tc conflicts cur_branch+           ; reportInjectivityErrors dflags ax cur_branch inj }       | otherwise       = return ()      gather_conflicts inj prev_branches cur_branch (acc, n) branch                -- n is 0-based index of branch in prev_branches       = case injectiveBranches inj cur_branch branch of+           -- Case 1B2 in Note [Verifying injectivity annotation] in FamInstEnv           InjectivityUnified ax1 ax2             | ax1 `isDominatedBy` (replace_br prev_branches n ax2)                 -> (acc, n + 1)@@ -1960,15 +2073,28 @@                    -> Type    -- ^ Rhs                    -> TcM () checkValidTyFamEqn fam_tc qvs typats rhs-  = do { checkValidFamPats fam_tc qvs typats rhs+  = do { checkValidTypePats fam_tc typats +         -- Check for things used on the right but not bound on the left+       ; checkFamPatBinders fam_tc qvs typats rhs++         -- Check for oversaturated visible kind arguments in a type family+         -- equation.+         -- See Note [Oversaturated type family equations]+       ; when (isTypeFamilyTyCon fam_tc) $+           case drop (tyConArity fam_tc) typats of+             [] -> pure ()+             spec_arg:_ ->+               addErr $ text "Illegal oversaturated visible kind argument:"+                    <+> quotes (char '@' <> pprParendType spec_arg)+          -- The argument patterns, and RHS, are all boxed tau types          -- E.g  Reject type family F (a :: k1) :: k2          --             type instance F (forall a. a->a) = ...          --             type instance F Int#             = ...          --             type instance F Int              = forall a. a->a          --             type instance F Int              = Int#-         -- See Trac #9357+         -- See #9357        ; checkValidMonoType rhs           -- We have a decidable instance unless otherwise permitted@@ -2005,23 +2131,6 @@                        --   [a,b,a,a] \\ [a,a] = [b,a]                        -- So we are counting repetitions -checkValidFamPats :: TyCon -> [Var]-                  -> [Type]   -- ^ patterns-                  -> Type     -- ^ RHS-                  -> TcM ()--- Patterns in a 'type instance' or 'data instance' decl should--- a) Shoule contain no type family applications---    (vanilla synonyms are fine, though)--- b) For associated types, are consistently instantiated-checkValidFamPats fam_tc qvs pats rhs-  = do { checkValidTypePats fam_tc pats--         -- Check for things used on the right but not bound on the left-       ; checkFamPatBinders fam_tc qvs pats rhs--       ; traceTc "checkValidFamPats" (ppr fam_tc <+> ppr pats)-       }- ----------------- checkFamPatBinders :: TyCon                    -> [TcTyVar]   -- Bound on LHS of family instance@@ -2041,42 +2150,43 @@               , text "qtvs:" <+> ppr qtvs               , text "rhs_tvs:" <+> ppr (fvVarSet rhs_fvs)               , text "pat_tvs:" <+> ppr pat_tvs-              , text "exact_pat_tvs:" <+> ppr exact_pat_tvs ]+              , text "inj_pat_tvs:" <+> ppr inj_pat_tvs ]           -- Check for implicitly-bound tyvars, mentioned on the          -- RHS but not bound on the LHS          --    data T            = MkT (forall (a::k). blah)          --    data family D Int = MkD (forall (a::k). blah)          -- In both cases, 'k' is not bound on the LHS, but is used on the RHS-         -- We catch the former in kcLHsQTyVars, and the latter right here+         -- We catch the former in kcDeclHeader, and the latter right here+         -- See Note [Check type-family instance binders]        ; check_tvs bad_rhs_tvs (text "mentioned in the RHS")                                (text "bound on the LHS of")           -- Check for explicitly forall'd variable that is not bound on LHS          --    data instance forall a.  T Int = MkT Int          -- See Note [Unused explicitly bound variables in a family pattern]+         -- See Note [Check type-family instance binders]        ; check_tvs bad_qtvs (text "bound by a forall")                             (text "used in")--         -- Check for oversaturated visible kind arguments in a type family-         -- equation.-         -- See Note [Oversaturated type family equations]-       ; when (isTypeFamilyTyCon fam_tc) $-           case drop (tyConArity fam_tc) pats of-             [] -> pure ()-             spec_arg:_ ->-               addErr $ text "Illegal oversaturated visible kind argument:"-                    <+> quotes (char '@' <> pprParendType spec_arg) }+       }   where-    pat_tvs       = tyCoVarsOfTypes pats-    exact_pat_tvs = exactTyCoVarsOfTypes pats-    rhs_fvs       = tyCoFVsOfType rhs-    used_tvs      = pat_tvs `unionVarSet` fvVarSet rhs_fvs-    bad_qtvs      = filterOut (`elemVarSet` used_tvs) qtvs-                    -- Bound but not used at all-    bad_rhs_tvs   = filterOut (`elemVarSet` exact_pat_tvs) (fvVarList rhs_fvs)-                    -- Used on RHS but not bound on LHS-    dodgy_tvs     = pat_tvs `minusVarSet` exact_pat_tvs+    pat_tvs     = tyCoVarsOfTypes pats+    inj_pat_tvs = fvVarSet $ injectiveVarsOfTypes False pats+      -- The type variables that are in injective positions.+      -- See Note [Dodgy binding sites in type family instances]+      -- NB: The False above is irrelevant, as we never have type families in+      -- patterns.+      --+      -- NB: It's OK to use the nondeterministic `fvVarSet` function here,+      -- since the order of `inj_pat_tvs` is never revealed in an error+      -- message.+    rhs_fvs     = tyCoFVsOfType rhs+    used_tvs    = pat_tvs `unionVarSet` fvVarSet rhs_fvs+    bad_qtvs    = filterOut (`elemVarSet` used_tvs) qtvs+                  -- Bound but not used at all+    bad_rhs_tvs = filterOut (`elemVarSet` inj_pat_tvs) (fvVarList rhs_fvs)+                  -- Used on RHS but not bound on LHS+    dodgy_tvs   = pat_tvs `minusVarSet` inj_pat_tvs      check_tvs tvs what what2       = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $@@ -2085,7 +2195,7 @@            2 (vcat [ text "but not" <+> what2 <+> text "the family instance"                    , mk_extra tvs ]) -    -- mk_extra: Trac #7536: give a decent error message for+    -- mk_extra: #7536: give a decent error message for     --         type T a = Int     --         type instance F (T a) = a     mk_extra tvs = ppWhen (any (`elemVarSet` dodgy_tvs) tvs) $@@ -2093,21 +2203,26 @@                       2 (pprTypeApp fam_tc (map expandTypeSynonyms pats))  --- | Checks for occurrences of type families in class instances and type/data--- family instances.+-- | Checks that a list of type patterns is valid in a matching (LHS)+-- position of a class instances or type/data family instance.+--+-- Specifically:+--    * All monotypes+--    * No type-family applications checkValidTypePats :: TyCon -> [Type] -> TcM ()-checkValidTypePats tc pat_ty_args = do-  -- Check that each of pat_ty_args is a monotype.-  -- One could imagine generalising to allow-  --      instance C (forall a. a->a)-  -- but we don't know what all the consequences might be.-  traverse_ checkValidMonoType pat_ty_args+checkValidTypePats tc pat_ty_args+  = do { -- Check that each of pat_ty_args is a monotype.+         -- One could imagine generalising to allow+         --      instance C (forall a. a->a)+         -- but we don't know what all the consequences might be.+         traverse_ checkValidMonoType pat_ty_args -  -- Ensure that no type family instances occur a type pattern-  case tcTyConAppTyFamInstsAndVis tc pat_ty_args of-    [] -> pure ()-    ((tf_is_invis_arg, tf_tc, tf_args):_) -> failWithTc $-      ty_fam_inst_illegal_err tf_is_invis_arg (mkTyConApp tf_tc tf_args)+       -- Ensure that no type family applications occur a type pattern+       ; case tcTyConAppTyFamInstsAndVis tc pat_ty_args of+            [] -> pure ()+            ((tf_is_invis_arg, tf_tc, tf_args):_) -> failWithTc $+               ty_fam_inst_illegal_err tf_is_invis_arg+                                       (mkTyConApp tf_tc tf_args) }   where     inst_ty = mkTyConApp tc pat_ty_args @@ -2221,10 +2336,92 @@                | otherwise                   = BindMe  -{- Note [Matching in the consistent-instantation check]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Check type-family instance binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a type family instance, we require (of course), type variables+used on the RHS are matched on the LHS. This is checked by+checkFamPatBinders.  Here is an interesting example:++    type family   T :: k+    type instance T = (Nothing :: Maybe a)++Upon a cursory glance, it may appear that the kind variable `a` is unbound+since there are no (visible) LHS patterns in `T`. However, there is an+*invisible* pattern due to the return kind, so inside of GHC, the instance+looks closer to this:++    type family T @k :: k+    type instance T @(Maybe a) = (Nothing :: Maybe a)++Here, we can see that `a` really is bound by a LHS type pattern, so `a` is in+fact not unbound. Contrast that with this example (#13985)++    type instance T = Proxy (Nothing :: Maybe a)++This would looks like this inside of GHC:++    type instance T @(*) = Proxy (Nothing :: Maybe a)++So this time, `a` is neither bound by a visible nor invisible type pattern on+the LHS, so `a` would be reported as not in scope.++Finally, here's one more brain-teaser (from #9574). In the example below:++    class Funct f where+      type Codomain f :: *+    instance Funct ('KProxy :: KProxy o) where+      type Codomain 'KProxy = NatTr (Proxy :: o -> *)++As it turns out, `o` is in scope in this example. That is because `o` is+bound by the kind signature of the LHS type pattern 'KProxy. To make this more+obvious, one can also write the instance like so:++    instance Funct ('KProxy :: KProxy o) where+      type Codomain ('KProxy :: KProxy o) = NatTr (Proxy :: o -> *)++Note [Dodgy binding sites in type family instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following example (from #7536):++  type T a = Int+  type instance F (T a) = a++This `F` instance is extremely fishy, since the RHS, `a`, purports to be+"bound" by the LHS pattern `T a`. "Bound" has scare quotes around it because+`T a` expands to `Int`, which doesn't mention at all, so it's as if one had+actually written:++  type instance F Int = a++That is clearly bogus, so to reject this, we check that every type variable+that is mentioned on the RHS is /actually/ bound on the LHS. In other words,+we need to do something slightly more sophisticated that just compute the free+variables of the LHS patterns.++It's tempting to just expand all type synonyms on the LHS and then compute+their free variables, but even that isn't sophisticated enough. After all,+an impish user could write the following (#17008):++  type family ConstType (a :: Type) :: Type where+    ConstType _ = Type++  type family F (x :: ConstType a) :: Type where+    F (x :: ConstType a) = a++Just like in the previous example, the `a` on the RHS isn't actually bound+on the LHS, but this time a type family is responsible for the deception, not+a type synonym.++We avoid both issues by requiring that all RHS type variables are mentioned+in injective positions on the left-hand side (by way of+`injectiveVarsOfTypes`). For instance, the `a` in `T a` is not in an injective+position, as `T` is not an injective type constructor, so we do not count that.+Similarly for the `a` in `ConstType a`.++Note [Matching in the consistent-instantation check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Matching the class-instance header to family-instance tyvars is-tricker than it sounds.  Consider (Trac #13972)+tricker than it sounds.  Consider (#13972)     class C (a :: k) where       type T k :: Type     instance C Left where@@ -2239,7 +2436,7 @@ We track the lexically-scoped type variables from the class-instance header in ai_tyvars. -Here's another example (Trac #14045a)+Here's another example (#14045a)     class C (a :: k) where       data S (a :: k)     instance C (z :: Bool) where@@ -2257,7 +2454,7 @@  Note [Checking consistent instantiation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See Trac #11450 for background discussion on this check.+See #11450 for background discussion on this check.    class C a b where     type T a x b@@ -2279,7 +2476,7 @@     instance C [p] Int       type T [q] y Int = ...   But from GHC 8.2 onwards, we don't.  It's much simpler this way.-  See Trac #11450.+  See #11450.  * When the class variable isn't used on the RHS of the type instance,   it's tempting to allow wildcards, thus@@ -2326,7 +2523,7 @@       CAux (Either x y) = x -> y    We decided that this restriction wasn't buying us much, so we opted not-  to pursue that design (see also GHC Trac #13398).+  to pursue that design (see also GHC #13398).  Implementation   * Form the mini-envt from the class type variables a,b@@ -2474,8 +2671,8 @@ *                                                                      * ************************************************************************ -Note [Bad telescopes]-~~~~~~~~~~~~~~~~~~~~~+Note [Bad TyCon telescopes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~ Now that we can mix type and kind variables, there are an awful lot of ways to shoot yourself in the foot. Here are some. @@ -2493,54 +2690,93 @@ a nice rule that all implicitly bound variables come before others, this is bogus. -To catch these errors, we call checkValidTelescope during kind-checking-datatype declarations. See also-Note [Required, Specified, and Inferred for types] in TcTyClsDecls.+To catch these errors, we call checkTyConTelescope during kind-checking+datatype declarations.  This checks for -Note [Keeping scoped variables in order: Explicit] discusses how this-check works for `forall x y z.` written in a type.+* Ill-scoped binders. From (1) and (2) above we can get putative+  kinds like+       T1 :: forall (a:k) (k:*) (b:k). SameKind a b -> *+  where 'k' is mentioned a's kind before k is bound +  This is easy to check for: just look for+  out-of-scope variables in the kind++* We should arguably also check for ambiguous binders+  but we don't.  See Note [Ambiguous kind vars].++See also+  * Note [Required, Specified, and Inferred for types] in TcTyClsDecls.+  * Note [Keeping scoped variables in order: Explicit] discusses how+    this check works for `forall x y z.` written in a type.++Note [Ambiguous kind vars]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to be concerned about ambiguous binders. Suppose we have the kind+     S1 :: forall k -> * -> *+     S2 :: forall k. * -> *+Here S1 is OK, because k is Required, and at a use of S1 we will+see (S1 *) or (S1 (*->*)) or whatever.++But S2 is /not/ OK because 'k' is Specfied (and hence invisible) and+we have no way (ever) to figure out how 'k' should be instantiated.+For example if we see (S2 Int), that tells us nothing about k's+instantiation.  (In this case we'll instantiate it to Any, but that+seems wrong.)  This is really the same test as we make for ambiguous+type in term type signatures.++Now, it's impossible for a Specified variable not to occur+at all in the kind -- after all, it is Specified so it must have+occurred.  (It /used/ to be possible; see tests T13983 and T7873.  But+with the advent of the forall-or-nothing rule for kind variables,+those strange cases went away.)++But one might worry about+    type v k = *+    S3 :: forall k. V k -> *+which appears to mention 'k' but doesn't really.  Or+    S4 :: forall k. F k -> *+where F is a type function.  But we simply don't check for+those cases of ambiguity, yet anyway.  The worst that can happen+is ambiguity at the call sites.++Historical note: this test used to be called reportFloatingKvs. -}  -- | Check a list of binders to see if they make a valid telescope.--- The key property we're checking for is scoping. For example:--- > data SameKind :: k -> k -> *--- > data X a k (b :: k) (c :: SameKind a b)--- Kind inference says that a's kind should be k. But that's impossible,--- because k isn't in scope when a is bound. This check has to come before--- general validity checking, because once we kind-generalise, this sort--- of problem is harder to spot (as we'll generalise over the unbound--- k in a's type.)------ See Note [Generalisation for type constructors] in TcTyClsDecls for---     data type declarations--- and Note [Keeping scoped variables in order: Explicit] in TcHsType---     for foralls-checkValidTelescope :: TyCon -> TcM ()-checkValidTelescope tc-  = unless (null bad_tcbs) $ addErr $+-- See Note [Bad TyCon telescopes]+type TelescopeAcc+      = ( TyVarSet   -- Bound earlier in the telescope+        , Bool       -- At least one binder occurred (in a kind) before+                     -- it was bound in the telescope.  E.g.+        )            --    T :: forall (a::k) k. blah++checkTyConTelescope :: TyCon -> TcM ()+checkTyConTelescope tc+  | bad_scope+  = -- See "Ill-scoped binders" in Note [Bad TyCon telescopes]+    addErr $     vcat [ hang (text "The kind of" <+> quotes (ppr tc) <+> text "is ill-scoped")-              2 (text "Inferred kind:" <+> ppr tc <+> dcolon <+> ppr_untidy (tyConKind tc))+              2 pp_tc_kind          , extra          , hang (text "Perhaps try this order instead:")-              2 (pprTyVars sorted_tidied_tvs) ]+              2 (pprTyVars sorted_tvs) ]++  | otherwise+  = return ()   where-    ppr_untidy ty = pprIfaceType (toIfaceType ty)     tcbs = tyConBinders tc-    tvs = binderVars tcbs-    (_, sorted_tidied_tvs) = tidyVarBndrs emptyTidyEnv (scopedSort tvs)+    tvs  = binderVars tcbs+    sorted_tvs = scopedSort tvs -    (_, bad_tcbs) = foldl add_one (mkVarSet tvs, []) tcbs+    (_, bad_scope) = foldl add_one (emptyVarSet, False) tcbs -    add_one :: (TyVarSet, [TyConBinder])-            -> TyConBinder -> (TyVarSet, [TyConBinder])-    add_one (bad_bndrs, acc) tvb-      | fkvs `intersectsVarSet` bad_bndrs = (bad', tvb : acc)-      | otherwise                         = (bad', acc)+    add_one :: TelescopeAcc -> TyConBinder -> TelescopeAcc+    add_one (bound, bad_scope) tcb+      = ( bound `extendVarSet` tv+        , bad_scope || not (isEmptyVarSet (fkvs `minusVarSet` bound)) )       where-        tv = binderVar tvb+        tv = binderVar tcb         fkvs = tyCoVarsOfType (tyVarKind tv)-        bad' = bad_bndrs `delVarSet` tv      inferred_tvs  = [ binderVar tcb                     | tcb <- tcbs, Inferred == tyConBinderArgFlag tcb ]@@ -2550,6 +2786,14 @@     pp_inf  = parens (text "namely:" <+> pprTyVars inferred_tvs)     pp_spec = parens (text "namely:" <+> pprTyVars specified_tvs) +    pp_tc_kind = text "Inferred kind:" <+> ppr tc <+> dcolon <+> ppr_untidy (tyConKind tc)+    ppr_untidy ty = pprIfaceType (toIfaceType ty)+      -- We need ppr_untidy here because pprType will tidy the type, which+      -- will turn the bogus kind we are trying to report+      --     T :: forall (a::k) k (b::k) -> blah+      -- into a misleadingly sanitised version+      --     T :: forall (a::k) k1 (b::k1) -> blah+     extra       | null inferred_tvs && null specified_tvs       = empty@@ -2580,7 +2824,7 @@ fvType (TyConApp _ tys)      = fvTypes tys fvType (LitTy {})            = [] fvType (AppTy fun arg)       = fvType fun ++ fvType arg-fvType (FunTy arg res)       = fvType arg ++ fvType res+fvType (FunTy _ arg res)     = fvType arg ++ fvType res fvType (ForAllTy (Bndr tv _) ty)   = fvType (tyVarKind tv) ++     filter (/= tv) (fvType ty)@@ -2597,7 +2841,7 @@ sizeType (TyConApp tc tys) = 1 + sizeTyConAppArgs tc tys sizeType (LitTy {})        = 1 sizeType (AppTy fun arg)   = sizeType fun + sizeType arg-sizeType (FunTy arg res)   = sizeType arg + sizeType res + 1+sizeType (FunTy _ arg res) = sizeType arg + sizeType res + 1 sizeType (ForAllTy _ ty)   = sizeType ty sizeType (CastTy ty _)     = sizeType ty sizeType (CoercionTy _)    = 0@@ -2614,7 +2858,7 @@ -- We are considering whether class constraints terminate. -- Equality constraints and constraints for the implicit -- parameter class always terminate so it is safe to say "size 0".--- See Trac #4200.+-- See #4200. sizePred :: PredType -> Int sizePred ty = goClass ty   where@@ -2636,10 +2880,9 @@   = isIPClass cls    -- Implicit parameter constraints always terminate because                      -- there are no instances for them --- they are only solved                      -- by "local instances" in expressions+    || isEqPredClass cls     || cls `hasKey` typeableClassKey     || cls `hasKey` coercibleTyConKey-    || cls `hasKey` eqTyConKey-    || cls `hasKey` heqTyConKey  -- | Tidy before printing a type ppr_tidy :: TidyEnv -> Type -> SDoc
compiler/utils/AsmUtils.hs view
@@ -8,7 +8,7 @@  import GhcPrelude -import Platform+import GHC.Platform import Outputable  -- | Generate a section type (e.g. @\@progbits@). See #13937.
+ compiler/utils/Dominators.hs view
@@ -0,0 +1,597 @@+{-# LANGUAGE RankNTypes, BangPatterns, FlexibleContexts, Strict #-}
+
+{- |
+  Module      :  Dominators
+  Copyright   :  (c) Matt Morrow 2009
+  License     :  BSD3
+  Maintainer  :  <morrow@moonpatio.com>
+  Stability   :  experimental
+  Portability :  portable
+
+  Taken from the dom-lt package.
+
+  The Lengauer-Tarjan graph dominators algorithm.
+
+    \[1\] Lengauer, Tarjan,
+      /A Fast Algorithm for Finding Dominators in a Flowgraph/, 1979.
+
+    \[2\] Muchnick,
+      /Advanced Compiler Design and Implementation/, 1997.
+
+    \[3\] Brisk, Sarrafzadeh,
+      /Interference Graphs for Procedures in Static Single/
+      /Information Form are Interval Graphs/, 2007.
+
+  Originally taken from the dom-lt package.
+-}
+
+module Dominators (
+   Node,Path,Edge
+  ,Graph,Rooted
+  ,idom,ipdom
+  ,domTree,pdomTree
+  ,dom,pdom
+  ,pddfs,rpddfs
+  ,fromAdj,fromEdges
+  ,toAdj,toEdges
+  ,asTree,asGraph
+  ,parents,ancestors
+) where
+
+import GhcPrelude
+
+import Data.Bifunctor
+import Data.Tuple (swap)
+
+import Data.Tree
+import Data.IntMap(IntMap)
+import Data.IntSet(IntSet)
+import qualified Data.IntMap.Strict as IM
+import qualified Data.IntSet as IS
+
+import Control.Monad
+import Control.Monad.ST.Strict
+
+import Data.Array.ST
+import Data.Array.Base hiding ((!))
+  -- (unsafeNewArray_
+  -- ,unsafeWrite,unsafeRead
+  -- ,readArray,writeArray)
+
+import Util (debugIsOn)
+
+-----------------------------------------------------------------------------
+
+type Node       = Int
+type Path       = [Node]
+type Edge       = (Node,Node)
+type Graph      = IntMap IntSet
+type Rooted     = (Node, Graph)
+
+-----------------------------------------------------------------------------
+
+-- | /Dominators/.
+-- Complexity as for @idom@
+dom :: Rooted -> [(Node, Path)]
+dom = ancestors . domTree
+
+-- | /Post-dominators/.
+-- Complexity as for @idom@.
+pdom :: Rooted -> [(Node, Path)]
+pdom = ancestors . pdomTree
+
+-- | /Dominator tree/.
+-- Complexity as for @idom@.
+domTree :: Rooted -> Tree Node
+domTree a@(r,_) =
+  let is = filter ((/=r).fst) (idom a)
+      tg = fromEdges (fmap swap is)
+  in asTree (r,tg)
+
+-- | /Post-dominator tree/.
+-- Complexity as for @idom@.
+pdomTree :: Rooted -> Tree Node
+pdomTree a@(r,_) =
+  let is = filter ((/=r).fst) (ipdom a)
+      tg = fromEdges (fmap swap is)
+  in asTree (r,tg)
+
+-- | /Immediate dominators/.
+-- /O(|E|*alpha(|E|,|V|))/, where /alpha(m,n)/ is
+-- \"a functional inverse of Ackermann's function\".
+--
+-- This Complexity bound assumes /O(1)/ indexing. Since we're
+-- using @IntMap@, it has an additional /lg |V|/ factor
+-- somewhere in there. I'm not sure where.
+idom :: Rooted -> [(Node,Node)]
+idom rg = runST (evalS idomM =<< initEnv (pruneReach rg))
+
+-- | /Immediate post-dominators/.
+-- Complexity as for @idom@.
+ipdom :: Rooted -> [(Node,Node)]
+ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predG rg)))
+
+-----------------------------------------------------------------------------
+
+-- | /Post-dominated depth-first search/.
+pddfs :: Rooted -> [Node]
+pddfs = reverse . rpddfs
+
+-- | /Reverse post-dominated depth-first search/.
+rpddfs :: Rooted -> [Node]
+rpddfs = concat . levels . pdomTree
+
+-----------------------------------------------------------------------------
+
+type Dom s a = S s (Env s) a
+type NodeSet    = IntSet
+type NodeMap a  = IntMap a
+data Env s = Env
+  {succE      :: !Graph
+  ,predE      :: !Graph
+  ,bucketE    :: !Graph
+  ,dfsE       :: {-# UNPACK #-}!Int
+  ,zeroE      :: {-# UNPACK #-}!Node
+  ,rootE      :: {-# UNPACK #-}!Node
+  ,labelE     :: {-# UNPACK #-}!(Arr s Node)
+  ,parentE    :: {-# UNPACK #-}!(Arr s Node)
+  ,ancestorE  :: {-# UNPACK #-}!(Arr s Node)
+  ,childE     :: {-# UNPACK #-}!(Arr s Node)
+  ,ndfsE      :: {-# UNPACK #-}!(Arr s Node)
+  ,dfnE       :: {-# UNPACK #-}!(Arr s Int)
+  ,sdnoE      :: {-# UNPACK #-}!(Arr s Int)
+  ,sizeE      :: {-# UNPACK #-}!(Arr s Int)
+  ,domE       :: {-# UNPACK #-}!(Arr s Node)
+  ,rnE        :: {-# UNPACK #-}!(Arr s Node)}
+
+-----------------------------------------------------------------------------
+
+idomM :: Dom s [(Node,Node)]
+idomM = do
+  dfsDom =<< rootM
+  n <- gets dfsE
+  forM_ [n,n-1..1] (\i-> do
+    w <- ndfsM i
+    sw <- sdnoM w
+    ps <- predsM w
+    forM_ ps (\v-> do
+      u <- eval v
+      su <- sdnoM u
+      when (su < sw)
+        (store sdnoE w su))
+    z <- ndfsM =<< sdnoM w
+    modify(\e->e{bucketE=IM.adjust
+                      (w`IS.insert`)
+                      z (bucketE e)})
+    pw <- parentM w
+    link pw w
+    bps <- bucketM pw
+    forM_ bps (\v-> do
+      u <- eval v
+      su <- sdnoM u
+      sv <- sdnoM v
+      let dv = case su < sv of
+                True-> u
+                False-> pw
+      store domE v dv))
+  forM_ [1..n] (\i-> do
+    w <- ndfsM i
+    j <- sdnoM w
+    z <- ndfsM j
+    dw <- domM w
+    when (dw /= z)
+      (do ddw <- domM dw
+          store domE w ddw))
+  fromEnv
+
+-----------------------------------------------------------------------------
+
+eval :: Node -> Dom s Node
+eval v = do
+  n0 <- zeroM
+  a  <- ancestorM v
+  case a==n0 of
+    True-> labelM v
+    False-> do
+      compress v
+      a   <- ancestorM v
+      l   <- labelM v
+      la  <- labelM a
+      sl  <- sdnoM l
+      sla <- sdnoM la
+      case sl <= sla of
+        True-> return l
+        False-> return la
+
+compress :: Node -> Dom s ()
+compress v = do
+  n0  <- zeroM
+  a   <- ancestorM v
+  aa  <- ancestorM a
+  when (aa /= n0) (do
+    compress a
+    a   <- ancestorM v
+    aa  <- ancestorM a
+    l   <- labelM v
+    la  <- labelM a
+    sl  <- sdnoM l
+    sla <- sdnoM la
+    when (sla < sl)
+      (store labelE v la)
+    store ancestorE v aa)
+
+-----------------------------------------------------------------------------
+
+link :: Node -> Node -> Dom s ()
+link v w = do
+  n0  <- zeroM
+  lw  <- labelM w
+  slw <- sdnoM lw
+  let balance s = do
+        c   <- childM s
+        lc  <- labelM c
+        slc <- sdnoM lc
+        case slw < slc of
+          False-> return s
+          True-> do
+            zs  <- sizeM s
+            zc  <- sizeM c
+            cc  <- childM c
+            zcc <- sizeM cc
+            case 2*zc <= zs+zcc of
+              True-> do
+                store ancestorE c s
+                store childE s cc
+                balance s
+              False-> do
+                store sizeE c zs
+                store ancestorE s c
+                balance c
+  s   <- balance w
+  lw  <- labelM w
+  zw  <- sizeM w
+  store labelE s lw
+  store sizeE v . (+zw) =<< sizeM v
+  let follow s = do
+        when (s /= n0) (do
+          store ancestorE s v
+          follow =<< childM s)
+  zv  <- sizeM v
+  follow =<< case zv < 2*zw of
+              False-> return s
+              True-> do
+                cv <- childM v
+                store childE v s
+                return cv
+
+-----------------------------------------------------------------------------
+
+dfsDom :: Node -> Dom s ()
+dfsDom i = do
+  _   <- go i
+  n0  <- zeroM
+  r   <- rootM
+  store parentE r n0
+  where go i = do
+          n <- nextM
+          store dfnE   i n
+          store sdnoE  i n
+          store ndfsE  n i
+          store labelE i i
+          ss <- succsM i
+          forM_ ss (\j-> do
+            s <- sdnoM j
+            case s==0 of
+              False-> return()
+              True-> do
+                store parentE j i
+                go j)
+
+-----------------------------------------------------------------------------
+
+initEnv :: Rooted -> ST s (Env s)
+initEnv (r0,g0) = do
+  let (g,rnmap) = renum 1 g0
+      pred      = predG g
+      r         = rnmap IM.! r0
+      n         = IM.size g
+      ns        = [0..n]
+      m         = n+1
+
+  let bucket = IM.fromList
+        (zip ns (repeat mempty))
+
+  rna <- newI m
+  writes rna (fmap swap
+        (IM.toList rnmap))
+
+  doms      <- newI m
+  sdno      <- newI m
+  size      <- newI m
+  parent    <- newI m
+  ancestor  <- newI m
+  child     <- newI m
+  label     <- newI m
+  ndfs      <- newI m
+  dfn       <- newI m
+
+  forM_ [0..n] (doms.=0)
+  forM_ [0..n] (sdno.=0)
+  forM_ [1..n] (size.=1)
+  forM_ [0..n] (ancestor.=0)
+  forM_ [0..n] (child.=0)
+
+  (doms.=r) r
+  (size.=0) 0
+  (label.=0) 0
+
+  return (Env
+    {rnE        = rna
+    ,dfsE       = 0
+    ,zeroE      = 0
+    ,rootE      = r
+    ,labelE     = label
+    ,parentE    = parent
+    ,ancestorE  = ancestor
+    ,childE     = child
+    ,ndfsE      = ndfs
+    ,dfnE       = dfn
+    ,sdnoE      = sdno
+    ,sizeE      = size
+    ,succE      = g
+    ,predE      = pred
+    ,bucketE    = bucket
+    ,domE       = doms})
+
+fromEnv :: Dom s [(Node,Node)]
+fromEnv = do
+  dom   <- gets domE
+  rn    <- gets rnE
+  -- r     <- gets rootE
+  (_,n) <- st (getBounds dom)
+  forM [1..n] (\i-> do
+    j <- st(rn!:i)
+    d <- st(dom!:i)
+    k <- st(rn!:d)
+    return (j,k))
+
+-----------------------------------------------------------------------------
+
+zeroM :: Dom s Node
+zeroM = gets zeroE
+domM :: Node -> Dom s Node
+domM = fetch domE
+rootM :: Dom s Node
+rootM = gets rootE
+succsM :: Node -> Dom s [Node]
+succsM i = gets (IS.toList . (! i) . succE)
+predsM :: Node -> Dom s [Node]
+predsM i = gets (IS.toList . (! i) . predE)
+bucketM :: Node -> Dom s [Node]
+bucketM i = gets (IS.toList . (! i) . bucketE)
+sizeM :: Node -> Dom s Int
+sizeM = fetch sizeE
+sdnoM :: Node -> Dom s Int
+sdnoM = fetch sdnoE
+-- dfnM :: Node -> Dom s Int
+-- dfnM = fetch dfnE
+ndfsM :: Int -> Dom s Node
+ndfsM = fetch ndfsE
+childM :: Node -> Dom s Node
+childM = fetch childE
+ancestorM :: Node -> Dom s Node
+ancestorM = fetch ancestorE
+parentM :: Node -> Dom s Node
+parentM = fetch parentE
+labelM :: Node -> Dom s Node
+labelM = fetch labelE
+nextM :: Dom s Int
+nextM = do
+  n <- gets dfsE
+  let n' = n+1
+  modify(\e->e{dfsE=n'})
+  return n'
+
+-----------------------------------------------------------------------------
+
+type A = STUArray
+type Arr s a = A s Int a
+
+infixl 9 !:
+infixr 2 .=
+
+(.=) :: (MArray (A s) a (ST s))
+     => Arr s a -> a -> Int -> ST s ()
+(v .= x) i
+  | debugIsOn = writeArray v i x
+  | otherwise = unsafeWrite v i x
+
+(!:) :: (MArray (A s) a (ST s))
+     => A s Int a -> Int -> ST s a
+a !: i
+  | debugIsOn = do
+      o <- readArray a i
+      return $! o
+  | otherwise = do
+      o <- unsafeRead a i
+      return $! o
+
+new :: (MArray (A s) a (ST s))
+    => Int -> ST s (Arr s a)
+new n = unsafeNewArray_ (0,n-1)
+
+newI :: Int -> ST s (Arr s Int)
+newI = new
+
+-- newD :: Int -> ST s (Arr s Double)
+-- newD = new
+
+-- dump :: (MArray (A s) a (ST s)) => Arr s a -> ST s [a]
+-- dump a = do
+--   (m,n) <- getBounds a
+--   forM [m..n] (\i -> a!:i)
+
+writes :: (MArray (A s) a (ST s))
+     => Arr s a -> [(Int,a)] -> ST s ()
+writes a xs = forM_ xs (\(i,x) -> (a.=x) i)
+
+-- arr :: (MArray (A s) a (ST s)) => [a] -> ST s (Arr s a)
+-- arr xs = do
+--   let n = length xs
+--   a <- new n
+--   go a n 0 xs
+--   return a
+--   where go _ _ _    [] = return ()
+--         go a n i (x:xs)
+--           | i <= n = (a.=x) i >> go a n (i+1) xs
+--           | otherwise = return ()
+
+-----------------------------------------------------------------------------
+
+(!) :: Monoid a => IntMap a -> Int -> a
+(!) g n = maybe mempty id (IM.lookup n g)
+
+fromAdj :: [(Node, [Node])] -> Graph
+fromAdj = IM.fromList . fmap (second IS.fromList)
+
+fromEdges :: [Edge] -> Graph
+fromEdges = collectI IS.union fst (IS.singleton . snd)
+
+toAdj :: Graph -> [(Node, [Node])]
+toAdj = fmap (second IS.toList) . IM.toList
+
+toEdges :: Graph -> [Edge]
+toEdges = concatMap (uncurry (fmap . (,))) . toAdj
+
+predG :: Graph -> Graph
+predG g = IM.unionWith IS.union (go g) g0
+  where g0 = fmap (const mempty) g
+        f :: IntMap IntSet -> Int -> IntSet -> IntMap IntSet
+        f m i a = foldl' (\m p -> IM.insertWith mappend p
+                                      (IS.singleton i) m)
+                        m
+                       (IS.toList a)
+        go :: IntMap IntSet -> IntMap IntSet
+        go = flip IM.foldlWithKey' mempty f
+
+pruneReach :: Rooted -> Rooted
+pruneReach (r,g) = (r,g2)
+  where is = reachable
+              (maybe mempty id
+                . flip IM.lookup g) $ r
+        g2 = IM.fromList
+            . fmap (second (IS.filter (`IS.member`is)))
+            . filter ((`IS.member`is) . fst)
+            . IM.toList $ g
+
+tip :: Tree a -> (a, [Tree a])
+tip (Node a ts) = (a, ts)
+
+parents :: Tree a -> [(a, a)]
+parents (Node i xs) = p i xs
+        ++ concatMap parents xs
+  where p i = fmap (flip (,) i . rootLabel)
+
+ancestors :: Tree a -> [(a, [a])]
+ancestors = go []
+  where go acc (Node i xs)
+          = let acc' = i:acc
+            in p acc' xs ++ concatMap (go acc') xs
+        p is = fmap (flip (,) is . rootLabel)
+
+asGraph :: Tree Node -> Rooted
+asGraph t@(Node a _) = let g = go t in (a, fromAdj g)
+  where go (Node a ts) = let as = (fst . unzip . fmap tip) ts
+                          in (a, as) : concatMap go ts
+
+asTree :: Rooted -> Tree Node
+asTree (r,g) = let go a = Node a (fmap go ((IS.toList . f) a))
+                   f = (g !)
+            in go r
+
+reachable :: (Node -> NodeSet) -> (Node -> NodeSet)
+reachable f a = go (IS.singleton a) a
+  where go seen a = let s = f a
+                        as = IS.toList (s `IS.difference` seen)
+                    in foldl' go (s `IS.union` seen) as
+
+collectI :: (c -> c -> c)
+        -> (a -> Int) -> (a -> c) -> [a] -> IntMap c
+collectI (<>) f g
+  = foldl' (\m a -> IM.insertWith (<>)
+                                  (f a)
+                                  (g a) m) mempty
+
+-- collect :: (Ord b) => (c -> c -> c)
+--         -> (a -> b) -> (a -> c) -> [a] -> Map b c
+-- collect (<>) f g
+--   = foldl' (\m a -> SM.insertWith (<>)
+--                                   (f a)
+--                                   (g a) m) mempty
+
+-- (renamed, old -> new)
+renum :: Int -> Graph -> (Graph, NodeMap Node)
+renum from = (\(_,m,g)->(g,m))
+  . IM.foldlWithKey'
+      f (from,mempty,mempty)
+  where
+    f :: (Int, NodeMap Node, IntMap IntSet) -> Node -> IntSet
+      -> (Int, NodeMap Node, IntMap IntSet)
+    f (!n,!env,!new) i ss =
+            let (j,n2,env2) = go n env i
+                (n3,env3,ss2) = IS.fold
+                  (\k (!n,!env,!new)->
+                      case go n env k of
+                        (l,n2,env2)-> (n2,env2,l `IS.insert` new))
+                  (n2,env2,mempty) ss
+                new2 = IM.insertWith IS.union j ss2 new
+            in (n3,env3,new2)
+    go :: Int
+        -> NodeMap Node
+        -> Node
+        -> (Node,Int,NodeMap Node)
+    go !n !env i =
+        case IM.lookup i env of
+        Just j -> (j,n,env)
+        Nothing -> (n,n+1,IM.insert i n env)
+
+-----------------------------------------------------------------------------
+
+newtype S z s a = S {unS :: forall o. (a -> s -> ST z o) -> s -> ST z o}
+instance Functor (S z s) where
+  fmap f (S g) = S (\k -> g (k . f))
+instance Monad (S z s) where
+  return = pure
+  S g >>= f = S (\k -> g (\a -> unS (f a) k))
+instance Applicative (S z s) where
+  pure a = S (\k -> k a)
+  (<*>) = ap
+-- get :: S z s s
+-- get = S (\k s -> k s s)
+gets :: (s -> a) -> S z s a
+gets f = S (\k s -> k (f s) s)
+-- set :: s -> S z s ()
+-- set s = S (\k _ -> k () s)
+modify :: (s -> s) -> S z s ()
+modify f = S (\k -> k () . f)
+-- runS :: S z s a -> s -> ST z (a, s)
+-- runS (S g) = g (\a s -> return (a,s))
+evalS :: S z s a -> s -> ST z a
+evalS (S g) = g ((return .) . const)
+-- execS :: S z s a -> s -> ST z s
+-- execS (S g) = g ((return .) . flip const)
+st :: ST z a -> S z s a
+st m = S (\k s-> do
+  a <- m
+  k a s)
+store :: (MArray (A z) a (ST z))
+      => (s -> Arr z a) -> Int -> a -> S z s ()
+store f i x = do
+  a <- gets f
+  st ((a.=x) i)
+fetch :: (MArray (A z) a (ST z))
+      => (s -> Arr z a) -> Int -> S z s a
+fetch f i = do
+  a <- gets f
+  st (a!:i)
+
compiler/utils/GraphPpr.hs view
@@ -16,7 +16,7 @@ import UniqSet import UniqFM -import Data.List+import Data.List (mapAccumL) import Data.Maybe
− compiler/utils/ListT.hs 
@@ -1,80 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}------------------------------------------------------------------------------ |--- Module      : Control.Monad.Logic--- Copyright   : (c) Dan Doel--- License     : BSD3------ Maintainer  : dan.doel@gmail.com--- Stability   : experimental--- Portability : non-portable (multi-parameter type classes)------ A backtracking, logic programming monad.------    Adapted from the paper---    /Backtracking, Interleaving, and Terminating---        Monad Transformers/, by---    Oleg Kiselyov, Chung-chieh Shan, Daniel P. Friedman, Amr Sabry---    (<http://www.cs.rutgers.edu/~ccshan/logicprog/ListT-icfp2005.pdf>).----------------------------------------------------------------------------module ListT (-    ListT(..),-    runListT,-    select,-    fold-  ) where--import GhcPrelude--import Control.Applicative--import Control.Monad-import Control.Monad.Fail as MonadFail------------------------------------------------------------------------------ | A monad transformer for performing backtracking computations--- layered over another monad 'm'-newtype ListT m a =-    ListT { unListT :: forall r. (a -> m r -> m r) -> m r -> m r }--select :: Monad m => [a] -> ListT m a-select xs = foldr (<|>) mzero (map pure xs)--fold :: ListT m a -> (a -> m r -> m r) -> m r -> m r-fold = runListT------------------------------------------------------------------------------ | Runs a ListT computation with the specified initial success and--- failure continuations.-runListT :: ListT m a -> (a -> m r -> m r) -> m r -> m r-runListT = unListT--instance Functor (ListT f) where-    fmap f lt = ListT $ \sk fk -> unListT lt (sk . f) fk--instance Applicative (ListT f) where-    pure a = ListT $ \sk fk -> sk a fk-    f <*> a = ListT $ \sk fk -> unListT f (\g fk' -> unListT a (sk . g) fk') fk--instance Alternative (ListT f) where-    empty = ListT $ \_ fk -> fk-    f1 <|> f2 = ListT $ \sk fk -> unListT f1 sk (unListT f2 sk fk)--instance Monad (ListT m) where-    m >>= f = ListT $ \sk fk -> unListT m (\a fk' -> unListT (f a) sk fk') fk-#if !MIN_VERSION_base(4,13,0)-    fail = MonadFail.fail-#endif--instance MonadFail.MonadFail (ListT m) where-    fail _ = ListT $ \_ fk -> fk--instance MonadPlus (ListT m) where-    mzero = ListT $ \_ fk -> fk-    m1 `mplus` m2 = ListT $ \sk fk -> unListT m1 sk (unListT m2 sk fk)
compiler/utils/State.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE UnboxedTuples #-}  module State where@@ -5,10 +6,7 @@ import GhcPrelude  newtype State s a = State { runState' :: s -> (# a, s #) }--instance Functor (State s) where-    fmap f m  = State $ \s -> case runState' m s of-                              (# r, s' #) -> (# f r, s' #)+    deriving (Functor)  instance Applicative (State s) where    pure x   = State $ \s -> (# x, s #)
compiler/utils/Stream.hs view
@@ -7,8 +7,8 @@ -- ----------------------------------------------------------------------------- module Stream (     Stream(..), yield, liftIO,-    collect, fromList,-    Stream.map, Stream.mapM, Stream.mapAccumL+    collect, collect_, consume, fromList,+    Stream.map, Stream.mapM, Stream.mapAccumL, Stream.mapAccumL_   ) where  import GhcPrelude@@ -71,6 +71,25 @@       Left () -> return (reverse acc)       Right (a, str') -> go str' (a:acc) +-- | Turn a Stream into an ordinary list, by demanding all the elements.+collect_ :: Monad m => Stream m a r -> m ([a], r)+collect_ str = go str []+ where+  go str acc = do+    r <- runStream str+    case r of+      Left r -> return (reverse acc, r)+      Right (a, str') -> go str' (a:acc)++consume :: Monad m => Stream m a b -> (a -> m ()) -> m b+consume str f = do+    r <- runStream str+    case r of+      Left ret -> return ret+      Right (a, str') -> do+        f a+        consume str' f+ -- | Turn a list into a 'Stream', by yielding each element in turn. fromList :: Monad m => [a] -> Stream m a () fromList = mapM_ yield@@ -104,3 +123,13 @@     Right (a, str') -> do       (c',b) <- f c a       return (Right (b, mapAccumL f c' str'))++mapAccumL_ :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a r+           -> Stream m b (c, r)+mapAccumL_ f c str = Stream $ do+  r <- runStream str+  case r of+    Left  r -> return (Left (c, r))+    Right (a, str') -> do+      (c',b) <- f c a+      return (Right (b, mapAccumL_ f c' str'))
− compiler/utils/md5.h 
@@ -1,18 +0,0 @@-/* MD5 message digest */-#pragma once--#include "HsFFI.h"--typedef HsWord32 word32;-typedef HsWord8  byte;--struct MD5Context {-        word32 buf[4];-        word32 bytes[2];-        word32 in[16];-};--void MD5Init(struct MD5Context *context);-void MD5Update(struct MD5Context *context, byte const *buf, int len);-void MD5Final(byte digest[16], struct MD5Context *context);-void MD5Transform(word32 buf[4], word32 const in[16]);
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 8.8.4.20210620+version: 8.10.1.20200324 license: BSD3 license-file: LICENSE category: Development@@ -18,12 +18,13 @@     llvm-passes     platformConstants extra-source-files:-    ghc-lib/generated/ghcautoconf.h-    ghc-lib/generated/ghcplatform.h-    ghc-lib/generated/GhclibDerivedConstants.h-    ghc-lib/generated/GHCConstantsHaskellExports.hs-    ghc-lib/generated/GHCConstantsHaskellWrappers.hs-    ghc-lib/generated/GHCConstantsHaskellType.hs+    ghc-lib/stage0/lib/ghcautoconf.h+    ghc-lib/stage0/lib/ghcplatform.h+    ghc-lib/stage0/lib/ghcversion.h+    ghc-lib/stage0/lib/DerivedConstants.h+    ghc-lib/stage0/lib/GHCConstantsHaskellExports.hs+    ghc-lib/stage0/lib/GHCConstantsHaskellType.hs+    ghc-lib/stage0/lib/GHCConstantsHaskellWrappers.hs     ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl     ghc-lib/stage0/compiler/build/primop-code-size.hs-incl     ghc-lib/stage0/compiler/build/primop-commutable.hs-incl@@ -39,40 +40,36 @@     ghc-lib/stage0/compiler/build/primop-vector-tys-exports.hs-incl     ghc-lib/stage0/compiler/build/primop-vector-tys.hs-incl     ghc-lib/stage0/compiler/build/primop-vector-uniques.hs-incl-    ghc-lib/stage0/compiler/build/ghc_boot_platform.h-    ghc-lib/stage0/compiler/build/Fingerprint.hs     includes/ghcconfig.h     includes/MachDeps.h     includes/stg/MachRegs.h     includes/CodeGen.Platform.hs+    compiler/HsVersions.h     compiler/Unique.h-    compiler/GhclibHsVersions.h-    compiler/nativeGen/NCG.h-    compiler/utils/md5.h+tested-with: GHC==8.8.2, GHC==8.6.5, GHC==8.4.4 source-repository head     type: git     location: git@github.com:digital-asset/ghc-lib.git  library     default-language:   Haskell2010+    default-extensions: NoImplicitPrelude     exposed: False     include-dirs:         includes-        ghc-lib/generated+        ghc-lib/stage0/lib         ghc-lib/stage0/compiler/build         compiler-        compiler/utils     ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS     cc-options: -DTHREADED_RTS-    cpp-options: -DSTAGE=2 -DTHREADED_RTS -DGHCI -DGHC_IN_GHCI+    cpp-options:  -DTHREADED_RTS  -DGHC_IN_GHCI     if !os(windows)         build-depends: unix     else         build-depends: Win32     build-depends:-        rts,-        ghc-prim > 0.2 && < 0.8,-        base >= 4.11 && < 4.16,+        ghc-prim > 0.2 && < 0.6,+        base >= 4.11 && < 4.14,         containers >= 0.5 && < 0.7,         bytestring >= 0.9 && < 0.11,         binary == 0.8.*,@@ -85,7 +82,7 @@         transformers == 0.5.*,         process >= 1 && < 1.7,         hpc == 0.6.*,-        ghc-lib-parser == 8.8.4.20210620+        ghc-lib-parser == 8.10.1.20200324     build-tools: alex >= 3.1, happy >= 1.19.4     other-extensions:         BangPatterns@@ -120,9 +117,8 @@         TypeSynonymInstances         UnboxedTuples         UndecidableInstances-    default-extensions:-        NoImplicitPrelude     hs-source-dirs:+        ghc-lib/stage0/libraries/ghc-boot/build         ghc-lib/stage0/compiler/build         libraries/template-haskell         compiler/specialise@@ -133,7 +129,6 @@         libraries/ghc-boot         compiler/backpack         compiler/simplStg-        compiler/codeGen         compiler/coreSyn         compiler/deSugar         compiler/hieFile@@ -142,13 +137,13 @@         compiler/stranal         compiler/rename         compiler/stgSyn-        compiler/hsSyn         compiler/iface         compiler/utils         libraries/ghci         compiler/ghci         compiler/main         compiler/cmm+        compiler/.         compiler     autogen-modules:         Paths_ghc_lib@@ -165,6 +160,7 @@         BufWrite,         ByteCodeTypes,         Class,+        CliOption,         CmdLineParser,         CmmType,         CoAxiom,@@ -172,6 +168,7 @@         ConLike,         Config,         Constants,+        Constraint,         CoreArity,         CoreFVs,         CoreMap,@@ -204,9 +201,11 @@         FastStringEnv,         FieldLabel,         FileCleanup,+        FileSettings,         Fingerprint,         FiniteMap,         ForeignCall,+        GHC.BaseDir,         GHC.Exts.Heap,         GHC.Exts.Heap.ClosureTypes,         GHC.Exts.Heap.Closures,@@ -217,34 +216,40 @@         GHC.Exts.Heap.Utils,         GHC.ForeignSrcLang,         GHC.ForeignSrcLang.Type,+        GHC.Hs,+        GHC.Hs.Binds,+        GHC.Hs.Decls,+        GHC.Hs.Doc,+        GHC.Hs.Dump,+        GHC.Hs.Expr,+        GHC.Hs.Extension,+        GHC.Hs.ImpExp,+        GHC.Hs.Instances,+        GHC.Hs.Lit,+        GHC.Hs.Pat,+        GHC.Hs.PlaceHolder,+        GHC.Hs.Types,+        GHC.Hs.Utils,+        GHC.HsToCore.PmCheck.Types,         GHC.LanguageExtensions,         GHC.LanguageExtensions.Type,         GHC.Lexeme,         GHC.PackageDb,+        GHC.Platform,         GHC.Serialized,+        GHC.UniqueSubdir,+        GHC.Version,         GHCi.BreakArray,         GHCi.FFI,         GHCi.Message,         GHCi.RemoteTypes,         GHCi.TH.Binary,         GhcMonad,+        GhcNameVersion,         GhcPrelude,         HaddockUtils,         HeaderInfo,         Hooks,-        HsBinds,-        HsDecls,-        HsDoc,-        HsDumpAst,-        HsExpr,-        HsExtension,-        HsImpExp,-        HsInstances,-        HsLit,-        HsPat,-        HsSyn,-        HsTypes,-        HsUtils,         HscTypes,         IOEnv,         Id,@@ -254,7 +259,6 @@         InstEnv,         InteractiveEvalTypes,         Json,-        Kind,         KnownUniques,         Language.Haskell.TH,         Language.Haskell.TH.LanguageExtensions,@@ -266,6 +270,7 @@         Language.Haskell.TH.Syntax,         Lexeme,         Lexer,+        LinkerTypes,         ListSetOps,         Literal,         Maybes,@@ -289,14 +294,12 @@         Parser,         PatSyn,         PipelineMonad,-        PlaceHolder,         PlainPanic,-        Platform,         PlatformConstants,         Plugins,-        PmExpr,         PprColour,         PprCore,+        Predicate,         PrelNames,         PrelRules,         Pretty,@@ -305,17 +308,25 @@         RdrName,         RepType,         Rules,+        Settings,         SizedSeq,         SrcLoc,         StringBuffer,         SysTools.BaseDir,         SysTools.Terminal,         TcEvidence,+        TcHoleFitTypes,+        TcOrigin,         TcRnTypes,         TcType,         ToIface,+        ToolSettings,         TrieMap,+        TyCoFVs,+        TyCoPpr,         TyCoRep,+        TyCoSubst,+        TyCoTidy,         TyCon,         Type,         TysPrim,@@ -351,8 +362,6 @@         CPrim         CSE         CallArity-        CgUtils-        Check         ClsInst         Cmm         CmmBuildInfoTables@@ -376,16 +385,7 @@         CmmSink         CmmSwitch         CmmUtils-        CodeGen.Platform-        CodeGen.Platform.ARM-        CodeGen.Platform.ARM64-        CodeGen.Platform.NoRegs-        CodeGen.Platform.PPC-        CodeGen.Platform.SPARC-        CodeGen.Platform.X86-        CodeGen.Platform.X86_64         CodeOutput-        Convert         CoreLint         CorePrep         CoreToStg@@ -394,6 +394,7 @@         Debugger         Desugar         DmdAnal+        Dominators         DriverBkp         DriverMkDepend         DriverPipeline@@ -424,6 +425,39 @@         FunDeps         GHC         GHC.HandleEncoding+        GHC.HsToCore.PmCheck+        GHC.HsToCore.PmCheck.Oracle+        GHC.HsToCore.PmCheck.Ppr+        GHC.Platform.ARM+        GHC.Platform.ARM64+        GHC.Platform.Host+        GHC.Platform.NoRegs+        GHC.Platform.PPC+        GHC.Platform.Regs+        GHC.Platform.S390X+        GHC.Platform.SPARC+        GHC.Platform.X86+        GHC.Platform.X86_64+        GHC.Settings+        GHC.StgToCmm+        GHC.StgToCmm.ArgRep+        GHC.StgToCmm.Bind+        GHC.StgToCmm.CgUtils+        GHC.StgToCmm.Closure+        GHC.StgToCmm.DataCon+        GHC.StgToCmm.Env+        GHC.StgToCmm.Expr+        GHC.StgToCmm.ExtCode+        GHC.StgToCmm.Foreign+        GHC.StgToCmm.Heap+        GHC.StgToCmm.Hpc+        GHC.StgToCmm.Layout+        GHC.StgToCmm.Monad+        GHC.StgToCmm.Prim+        GHC.StgToCmm.Prof+        GHC.StgToCmm.Ticky+        GHC.StgToCmm.Utils+        GHC.ThToHs         GHCi         GHCi.BinaryArray         GHCi.CreateBCO@@ -459,7 +493,6 @@         Language.Haskell.TH.Quote         LiberateCase         Linker-        ListT         Llvm         Llvm.AbsSyn         Llvm.MetaData@@ -562,23 +595,6 @@         Specialise         State         StaticPtrTable-        StgCmm-        StgCmmArgRep-        StgCmmBind-        StgCmmClosure-        StgCmmCon-        StgCmmEnv-        StgCmmExpr-        StgCmmExtCode-        StgCmmForeign-        StgCmmHeap-        StgCmmHpc-        StgCmmLayout-        StgCmmMonad-        StgCmmPrim-        StgCmmProf-        StgCmmTicky-        StgCmmUtils         StgCse         StgFVs         StgLiftLams@@ -594,6 +610,7 @@         SysTools.ExtraObj         SysTools.Info         SysTools.Process+        SysTools.Settings         SysTools.Tasks         THNames         TargetReg@@ -639,11 +656,9 @@         TcTyDecls         TcTypeNats         TcTypeable-        TcTypeableValidity         TcUnify         TcValidity         TidyPgm-        TmOracle         UnVarGraph         UnariseStg         UniqMap
− ghc-lib/generated/GHCConstantsHaskellExports.hs 
@@ -1,125 +0,0 @@-    cONTROL_GROUP_CONST_291,-    sTD_HDR_SIZE,-    pROF_HDR_SIZE,-    bLOCK_SIZE,-    bLOCKS_PER_MBLOCK,-    tICKY_BIN_COUNT,-    oFFSET_StgRegTable_rR1,-    oFFSET_StgRegTable_rR2,-    oFFSET_StgRegTable_rR3,-    oFFSET_StgRegTable_rR4,-    oFFSET_StgRegTable_rR5,-    oFFSET_StgRegTable_rR6,-    oFFSET_StgRegTable_rR7,-    oFFSET_StgRegTable_rR8,-    oFFSET_StgRegTable_rR9,-    oFFSET_StgRegTable_rR10,-    oFFSET_StgRegTable_rF1,-    oFFSET_StgRegTable_rF2,-    oFFSET_StgRegTable_rF3,-    oFFSET_StgRegTable_rF4,-    oFFSET_StgRegTable_rF5,-    oFFSET_StgRegTable_rF6,-    oFFSET_StgRegTable_rD1,-    oFFSET_StgRegTable_rD2,-    oFFSET_StgRegTable_rD3,-    oFFSET_StgRegTable_rD4,-    oFFSET_StgRegTable_rD5,-    oFFSET_StgRegTable_rD6,-    oFFSET_StgRegTable_rXMM1,-    oFFSET_StgRegTable_rXMM2,-    oFFSET_StgRegTable_rXMM3,-    oFFSET_StgRegTable_rXMM4,-    oFFSET_StgRegTable_rXMM5,-    oFFSET_StgRegTable_rXMM6,-    oFFSET_StgRegTable_rYMM1,-    oFFSET_StgRegTable_rYMM2,-    oFFSET_StgRegTable_rYMM3,-    oFFSET_StgRegTable_rYMM4,-    oFFSET_StgRegTable_rYMM5,-    oFFSET_StgRegTable_rYMM6,-    oFFSET_StgRegTable_rZMM1,-    oFFSET_StgRegTable_rZMM2,-    oFFSET_StgRegTable_rZMM3,-    oFFSET_StgRegTable_rZMM4,-    oFFSET_StgRegTable_rZMM5,-    oFFSET_StgRegTable_rZMM6,-    oFFSET_StgRegTable_rL1,-    oFFSET_StgRegTable_rSp,-    oFFSET_StgRegTable_rSpLim,-    oFFSET_StgRegTable_rHp,-    oFFSET_StgRegTable_rHpLim,-    oFFSET_StgRegTable_rCCCS,-    oFFSET_StgRegTable_rCurrentTSO,-    oFFSET_StgRegTable_rCurrentNursery,-    oFFSET_StgRegTable_rHpAlloc,-    oFFSET_stgEagerBlackholeInfo,-    oFFSET_stgGCEnter1,-    oFFSET_stgGCFun,-    oFFSET_Capability_r,-    oFFSET_bdescr_start,-    oFFSET_bdescr_free,-    oFFSET_bdescr_blocks,-    oFFSET_bdescr_flags,-    sIZEOF_CostCentreStack,-    oFFSET_CostCentreStack_mem_alloc,-    oFFSET_CostCentreStack_scc_count,-    oFFSET_StgHeader_ccs,-    oFFSET_StgHeader_ldvw,-    sIZEOF_StgSMPThunkHeader,-    oFFSET_StgEntCounter_allocs,-    oFFSET_StgEntCounter_allocd,-    oFFSET_StgEntCounter_registeredp,-    oFFSET_StgEntCounter_link,-    oFFSET_StgEntCounter_entry_count,-    sIZEOF_StgUpdateFrame_NoHdr,-    sIZEOF_StgMutArrPtrs_NoHdr,-    oFFSET_StgMutArrPtrs_ptrs,-    oFFSET_StgMutArrPtrs_size,-    sIZEOF_StgSmallMutArrPtrs_NoHdr,-    oFFSET_StgSmallMutArrPtrs_ptrs,-    sIZEOF_StgArrBytes_NoHdr,-    oFFSET_StgArrBytes_bytes,-    oFFSET_StgTSO_alloc_limit,-    oFFSET_StgTSO_cccs,-    oFFSET_StgTSO_stackobj,-    oFFSET_StgStack_sp,-    oFFSET_StgStack_stack,-    oFFSET_StgUpdateFrame_updatee,-    oFFSET_StgFunInfoExtraFwd_arity,-    sIZEOF_StgFunInfoExtraRev,-    oFFSET_StgFunInfoExtraRev_arity,-    mAX_SPEC_SELECTEE_SIZE,-    mAX_SPEC_AP_SIZE,-    mIN_PAYLOAD_SIZE,-    mIN_INTLIKE,-    mAX_INTLIKE,-    mIN_CHARLIKE,-    mAX_CHARLIKE,-    mUT_ARR_PTRS_CARD_BITS,-    mAX_Vanilla_REG,-    mAX_Float_REG,-    mAX_Double_REG,-    mAX_Long_REG,-    mAX_XMM_REG,-    mAX_Real_Vanilla_REG,-    mAX_Real_Float_REG,-    mAX_Real_Double_REG,-    mAX_Real_XMM_REG,-    mAX_Real_Long_REG,-    rESERVED_C_STACK_BYTES,-    rESERVED_STACK_WORDS,-    aP_STACK_SPLIM,-    wORD_SIZE,-    dOUBLE_SIZE,-    cINT_SIZE,-    cLONG_SIZE,-    cLONG_LONG_SIZE,-    bITMAP_BITS_SHIFT,-    tAG_BITS,-    wORDS_BIGENDIAN,-    dYNAMIC_BY_DEFAULT,-    lDV_SHIFT,-    iLDV_CREATE_MASK,-    iLDV_STATE_CREATE,-    iLDV_STATE_USE,
− ghc-lib/generated/GHCConstantsHaskellType.hs 
@@ -1,134 +0,0 @@-data PlatformConstants = PlatformConstants {-    pc_platformConstants :: ()-    , pc_CONTROL_GROUP_CONST_291 :: Int-    , pc_STD_HDR_SIZE :: Int-    , pc_PROF_HDR_SIZE :: Int-    , pc_BLOCK_SIZE :: Int-    , pc_BLOCKS_PER_MBLOCK :: Int-    , pc_TICKY_BIN_COUNT :: Int-    , pc_OFFSET_StgRegTable_rR1 :: Int-    , pc_OFFSET_StgRegTable_rR2 :: Int-    , pc_OFFSET_StgRegTable_rR3 :: Int-    , pc_OFFSET_StgRegTable_rR4 :: Int-    , pc_OFFSET_StgRegTable_rR5 :: Int-    , pc_OFFSET_StgRegTable_rR6 :: Int-    , pc_OFFSET_StgRegTable_rR7 :: Int-    , pc_OFFSET_StgRegTable_rR8 :: Int-    , pc_OFFSET_StgRegTable_rR9 :: Int-    , pc_OFFSET_StgRegTable_rR10 :: Int-    , pc_OFFSET_StgRegTable_rF1 :: Int-    , pc_OFFSET_StgRegTable_rF2 :: Int-    , pc_OFFSET_StgRegTable_rF3 :: Int-    , pc_OFFSET_StgRegTable_rF4 :: Int-    , pc_OFFSET_StgRegTable_rF5 :: Int-    , pc_OFFSET_StgRegTable_rF6 :: Int-    , pc_OFFSET_StgRegTable_rD1 :: Int-    , pc_OFFSET_StgRegTable_rD2 :: Int-    , pc_OFFSET_StgRegTable_rD3 :: Int-    , pc_OFFSET_StgRegTable_rD4 :: Int-    , pc_OFFSET_StgRegTable_rD5 :: Int-    , pc_OFFSET_StgRegTable_rD6 :: Int-    , pc_OFFSET_StgRegTable_rXMM1 :: Int-    , pc_OFFSET_StgRegTable_rXMM2 :: Int-    , pc_OFFSET_StgRegTable_rXMM3 :: Int-    , pc_OFFSET_StgRegTable_rXMM4 :: Int-    , pc_OFFSET_StgRegTable_rXMM5 :: Int-    , pc_OFFSET_StgRegTable_rXMM6 :: Int-    , pc_OFFSET_StgRegTable_rYMM1 :: Int-    , pc_OFFSET_StgRegTable_rYMM2 :: Int-    , pc_OFFSET_StgRegTable_rYMM3 :: Int-    , pc_OFFSET_StgRegTable_rYMM4 :: Int-    , pc_OFFSET_StgRegTable_rYMM5 :: Int-    , pc_OFFSET_StgRegTable_rYMM6 :: Int-    , pc_OFFSET_StgRegTable_rZMM1 :: Int-    , pc_OFFSET_StgRegTable_rZMM2 :: Int-    , pc_OFFSET_StgRegTable_rZMM3 :: Int-    , pc_OFFSET_StgRegTable_rZMM4 :: Int-    , pc_OFFSET_StgRegTable_rZMM5 :: Int-    , pc_OFFSET_StgRegTable_rZMM6 :: Int-    , pc_OFFSET_StgRegTable_rL1 :: Int-    , pc_OFFSET_StgRegTable_rSp :: Int-    , pc_OFFSET_StgRegTable_rSpLim :: Int-    , pc_OFFSET_StgRegTable_rHp :: Int-    , pc_OFFSET_StgRegTable_rHpLim :: Int-    , pc_OFFSET_StgRegTable_rCCCS :: Int-    , pc_OFFSET_StgRegTable_rCurrentTSO :: Int-    , pc_OFFSET_StgRegTable_rCurrentNursery :: Int-    , pc_OFFSET_StgRegTable_rHpAlloc :: Int-    , pc_OFFSET_stgEagerBlackholeInfo :: Int-    , pc_OFFSET_stgGCEnter1 :: Int-    , pc_OFFSET_stgGCFun :: Int-    , pc_OFFSET_Capability_r :: Int-    , pc_OFFSET_bdescr_start :: Int-    , pc_OFFSET_bdescr_free :: Int-    , pc_OFFSET_bdescr_blocks :: Int-    , pc_OFFSET_bdescr_flags :: Int-    , pc_SIZEOF_CostCentreStack :: Int-    , pc_OFFSET_CostCentreStack_mem_alloc :: Int-    , pc_REP_CostCentreStack_mem_alloc :: Int-    , pc_OFFSET_CostCentreStack_scc_count :: Int-    , pc_REP_CostCentreStack_scc_count :: Int-    , pc_OFFSET_StgHeader_ccs :: Int-    , pc_OFFSET_StgHeader_ldvw :: Int-    , pc_SIZEOF_StgSMPThunkHeader :: Int-    , pc_OFFSET_StgEntCounter_allocs :: Int-    , pc_REP_StgEntCounter_allocs :: Int-    , pc_OFFSET_StgEntCounter_allocd :: Int-    , pc_REP_StgEntCounter_allocd :: Int-    , pc_OFFSET_StgEntCounter_registeredp :: Int-    , pc_OFFSET_StgEntCounter_link :: Int-    , pc_OFFSET_StgEntCounter_entry_count :: Int-    , pc_SIZEOF_StgUpdateFrame_NoHdr :: Int-    , pc_SIZEOF_StgMutArrPtrs_NoHdr :: Int-    , pc_OFFSET_StgMutArrPtrs_ptrs :: Int-    , pc_OFFSET_StgMutArrPtrs_size :: Int-    , pc_SIZEOF_StgSmallMutArrPtrs_NoHdr :: Int-    , pc_OFFSET_StgSmallMutArrPtrs_ptrs :: Int-    , pc_SIZEOF_StgArrBytes_NoHdr :: Int-    , pc_OFFSET_StgArrBytes_bytes :: Int-    , pc_OFFSET_StgTSO_alloc_limit :: Int-    , pc_OFFSET_StgTSO_cccs :: Int-    , pc_OFFSET_StgTSO_stackobj :: Int-    , pc_OFFSET_StgStack_sp :: Int-    , pc_OFFSET_StgStack_stack :: Int-    , pc_OFFSET_StgUpdateFrame_updatee :: Int-    , pc_OFFSET_StgFunInfoExtraFwd_arity :: Int-    , pc_REP_StgFunInfoExtraFwd_arity :: Int-    , pc_SIZEOF_StgFunInfoExtraRev :: Int-    , pc_OFFSET_StgFunInfoExtraRev_arity :: Int-    , pc_REP_StgFunInfoExtraRev_arity :: Int-    , pc_MAX_SPEC_SELECTEE_SIZE :: Int-    , pc_MAX_SPEC_AP_SIZE :: Int-    , pc_MIN_PAYLOAD_SIZE :: Int-    , pc_MIN_INTLIKE :: Int-    , pc_MAX_INTLIKE :: Int-    , pc_MIN_CHARLIKE :: Int-    , pc_MAX_CHARLIKE :: Int-    , pc_MUT_ARR_PTRS_CARD_BITS :: Int-    , pc_MAX_Vanilla_REG :: Int-    , pc_MAX_Float_REG :: Int-    , pc_MAX_Double_REG :: Int-    , pc_MAX_Long_REG :: Int-    , pc_MAX_XMM_REG :: Int-    , pc_MAX_Real_Vanilla_REG :: Int-    , pc_MAX_Real_Float_REG :: Int-    , pc_MAX_Real_Double_REG :: Int-    , pc_MAX_Real_XMM_REG :: Int-    , pc_MAX_Real_Long_REG :: Int-    , pc_RESERVED_C_STACK_BYTES :: Int-    , pc_RESERVED_STACK_WORDS :: Int-    , pc_AP_STACK_SPLIM :: Int-    , pc_WORD_SIZE :: Int-    , pc_DOUBLE_SIZE :: Int-    , pc_CINT_SIZE :: Int-    , pc_CLONG_SIZE :: Int-    , pc_CLONG_LONG_SIZE :: Int-    , pc_BITMAP_BITS_SHIFT :: Int-    , pc_TAG_BITS :: Int-    , pc_WORDS_BIGENDIAN :: Bool-    , pc_DYNAMIC_BY_DEFAULT :: Bool-    , pc_LDV_SHIFT :: Int-    , pc_ILDV_CREATE_MASK :: Integer-    , pc_ILDV_STATE_CREATE :: Integer-    , pc_ILDV_STATE_USE :: Integer-  } deriving Read
− ghc-lib/generated/GHCConstantsHaskellWrappers.hs 
@@ -1,250 +0,0 @@-cONTROL_GROUP_CONST_291 :: DynFlags -> Int-cONTROL_GROUP_CONST_291 dflags = pc_CONTROL_GROUP_CONST_291 (sPlatformConstants (settings dflags))-sTD_HDR_SIZE :: DynFlags -> Int-sTD_HDR_SIZE dflags = pc_STD_HDR_SIZE (sPlatformConstants (settings dflags))-pROF_HDR_SIZE :: DynFlags -> Int-pROF_HDR_SIZE dflags = pc_PROF_HDR_SIZE (sPlatformConstants (settings dflags))-bLOCK_SIZE :: DynFlags -> Int-bLOCK_SIZE dflags = pc_BLOCK_SIZE (sPlatformConstants (settings dflags))-bLOCKS_PER_MBLOCK :: DynFlags -> Int-bLOCKS_PER_MBLOCK dflags = pc_BLOCKS_PER_MBLOCK (sPlatformConstants (settings dflags))-tICKY_BIN_COUNT :: DynFlags -> Int-tICKY_BIN_COUNT dflags = pc_TICKY_BIN_COUNT (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rR1 :: DynFlags -> Int-oFFSET_StgRegTable_rR1 dflags = pc_OFFSET_StgRegTable_rR1 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rR2 :: DynFlags -> Int-oFFSET_StgRegTable_rR2 dflags = pc_OFFSET_StgRegTable_rR2 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rR3 :: DynFlags -> Int-oFFSET_StgRegTable_rR3 dflags = pc_OFFSET_StgRegTable_rR3 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rR4 :: DynFlags -> Int-oFFSET_StgRegTable_rR4 dflags = pc_OFFSET_StgRegTable_rR4 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rR5 :: DynFlags -> Int-oFFSET_StgRegTable_rR5 dflags = pc_OFFSET_StgRegTable_rR5 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rR6 :: DynFlags -> Int-oFFSET_StgRegTable_rR6 dflags = pc_OFFSET_StgRegTable_rR6 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rR7 :: DynFlags -> Int-oFFSET_StgRegTable_rR7 dflags = pc_OFFSET_StgRegTable_rR7 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rR8 :: DynFlags -> Int-oFFSET_StgRegTable_rR8 dflags = pc_OFFSET_StgRegTable_rR8 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rR9 :: DynFlags -> Int-oFFSET_StgRegTable_rR9 dflags = pc_OFFSET_StgRegTable_rR9 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rR10 :: DynFlags -> Int-oFFSET_StgRegTable_rR10 dflags = pc_OFFSET_StgRegTable_rR10 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rF1 :: DynFlags -> Int-oFFSET_StgRegTable_rF1 dflags = pc_OFFSET_StgRegTable_rF1 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rF2 :: DynFlags -> Int-oFFSET_StgRegTable_rF2 dflags = pc_OFFSET_StgRegTable_rF2 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rF3 :: DynFlags -> Int-oFFSET_StgRegTable_rF3 dflags = pc_OFFSET_StgRegTable_rF3 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rF4 :: DynFlags -> Int-oFFSET_StgRegTable_rF4 dflags = pc_OFFSET_StgRegTable_rF4 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rF5 :: DynFlags -> Int-oFFSET_StgRegTable_rF5 dflags = pc_OFFSET_StgRegTable_rF5 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rF6 :: DynFlags -> Int-oFFSET_StgRegTable_rF6 dflags = pc_OFFSET_StgRegTable_rF6 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rD1 :: DynFlags -> Int-oFFSET_StgRegTable_rD1 dflags = pc_OFFSET_StgRegTable_rD1 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rD2 :: DynFlags -> Int-oFFSET_StgRegTable_rD2 dflags = pc_OFFSET_StgRegTable_rD2 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rD3 :: DynFlags -> Int-oFFSET_StgRegTable_rD3 dflags = pc_OFFSET_StgRegTable_rD3 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rD4 :: DynFlags -> Int-oFFSET_StgRegTable_rD4 dflags = pc_OFFSET_StgRegTable_rD4 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rD5 :: DynFlags -> Int-oFFSET_StgRegTable_rD5 dflags = pc_OFFSET_StgRegTable_rD5 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rD6 :: DynFlags -> Int-oFFSET_StgRegTable_rD6 dflags = pc_OFFSET_StgRegTable_rD6 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rXMM1 :: DynFlags -> Int-oFFSET_StgRegTable_rXMM1 dflags = pc_OFFSET_StgRegTable_rXMM1 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rXMM2 :: DynFlags -> Int-oFFSET_StgRegTable_rXMM2 dflags = pc_OFFSET_StgRegTable_rXMM2 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rXMM3 :: DynFlags -> Int-oFFSET_StgRegTable_rXMM3 dflags = pc_OFFSET_StgRegTable_rXMM3 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rXMM4 :: DynFlags -> Int-oFFSET_StgRegTable_rXMM4 dflags = pc_OFFSET_StgRegTable_rXMM4 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rXMM5 :: DynFlags -> Int-oFFSET_StgRegTable_rXMM5 dflags = pc_OFFSET_StgRegTable_rXMM5 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rXMM6 :: DynFlags -> Int-oFFSET_StgRegTable_rXMM6 dflags = pc_OFFSET_StgRegTable_rXMM6 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rYMM1 :: DynFlags -> Int-oFFSET_StgRegTable_rYMM1 dflags = pc_OFFSET_StgRegTable_rYMM1 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rYMM2 :: DynFlags -> Int-oFFSET_StgRegTable_rYMM2 dflags = pc_OFFSET_StgRegTable_rYMM2 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rYMM3 :: DynFlags -> Int-oFFSET_StgRegTable_rYMM3 dflags = pc_OFFSET_StgRegTable_rYMM3 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rYMM4 :: DynFlags -> Int-oFFSET_StgRegTable_rYMM4 dflags = pc_OFFSET_StgRegTable_rYMM4 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rYMM5 :: DynFlags -> Int-oFFSET_StgRegTable_rYMM5 dflags = pc_OFFSET_StgRegTable_rYMM5 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rYMM6 :: DynFlags -> Int-oFFSET_StgRegTable_rYMM6 dflags = pc_OFFSET_StgRegTable_rYMM6 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rZMM1 :: DynFlags -> Int-oFFSET_StgRegTable_rZMM1 dflags = pc_OFFSET_StgRegTable_rZMM1 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rZMM2 :: DynFlags -> Int-oFFSET_StgRegTable_rZMM2 dflags = pc_OFFSET_StgRegTable_rZMM2 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rZMM3 :: DynFlags -> Int-oFFSET_StgRegTable_rZMM3 dflags = pc_OFFSET_StgRegTable_rZMM3 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rZMM4 :: DynFlags -> Int-oFFSET_StgRegTable_rZMM4 dflags = pc_OFFSET_StgRegTable_rZMM4 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rZMM5 :: DynFlags -> Int-oFFSET_StgRegTable_rZMM5 dflags = pc_OFFSET_StgRegTable_rZMM5 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rZMM6 :: DynFlags -> Int-oFFSET_StgRegTable_rZMM6 dflags = pc_OFFSET_StgRegTable_rZMM6 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rL1 :: DynFlags -> Int-oFFSET_StgRegTable_rL1 dflags = pc_OFFSET_StgRegTable_rL1 (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rSp :: DynFlags -> Int-oFFSET_StgRegTable_rSp dflags = pc_OFFSET_StgRegTable_rSp (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rSpLim :: DynFlags -> Int-oFFSET_StgRegTable_rSpLim dflags = pc_OFFSET_StgRegTable_rSpLim (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rHp :: DynFlags -> Int-oFFSET_StgRegTable_rHp dflags = pc_OFFSET_StgRegTable_rHp (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rHpLim :: DynFlags -> Int-oFFSET_StgRegTable_rHpLim dflags = pc_OFFSET_StgRegTable_rHpLim (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rCCCS :: DynFlags -> Int-oFFSET_StgRegTable_rCCCS dflags = pc_OFFSET_StgRegTable_rCCCS (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rCurrentTSO :: DynFlags -> Int-oFFSET_StgRegTable_rCurrentTSO dflags = pc_OFFSET_StgRegTable_rCurrentTSO (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rCurrentNursery :: DynFlags -> Int-oFFSET_StgRegTable_rCurrentNursery dflags = pc_OFFSET_StgRegTable_rCurrentNursery (sPlatformConstants (settings dflags))-oFFSET_StgRegTable_rHpAlloc :: DynFlags -> Int-oFFSET_StgRegTable_rHpAlloc dflags = pc_OFFSET_StgRegTable_rHpAlloc (sPlatformConstants (settings dflags))-oFFSET_stgEagerBlackholeInfo :: DynFlags -> Int-oFFSET_stgEagerBlackholeInfo dflags = pc_OFFSET_stgEagerBlackholeInfo (sPlatformConstants (settings dflags))-oFFSET_stgGCEnter1 :: DynFlags -> Int-oFFSET_stgGCEnter1 dflags = pc_OFFSET_stgGCEnter1 (sPlatformConstants (settings dflags))-oFFSET_stgGCFun :: DynFlags -> Int-oFFSET_stgGCFun dflags = pc_OFFSET_stgGCFun (sPlatformConstants (settings dflags))-oFFSET_Capability_r :: DynFlags -> Int-oFFSET_Capability_r dflags = pc_OFFSET_Capability_r (sPlatformConstants (settings dflags))-oFFSET_bdescr_start :: DynFlags -> Int-oFFSET_bdescr_start dflags = pc_OFFSET_bdescr_start (sPlatformConstants (settings dflags))-oFFSET_bdescr_free :: DynFlags -> Int-oFFSET_bdescr_free dflags = pc_OFFSET_bdescr_free (sPlatformConstants (settings dflags))-oFFSET_bdescr_blocks :: DynFlags -> Int-oFFSET_bdescr_blocks dflags = pc_OFFSET_bdescr_blocks (sPlatformConstants (settings dflags))-oFFSET_bdescr_flags :: DynFlags -> Int-oFFSET_bdescr_flags dflags = pc_OFFSET_bdescr_flags (sPlatformConstants (settings dflags))-sIZEOF_CostCentreStack :: DynFlags -> Int-sIZEOF_CostCentreStack dflags = pc_SIZEOF_CostCentreStack (sPlatformConstants (settings dflags))-oFFSET_CostCentreStack_mem_alloc :: DynFlags -> Int-oFFSET_CostCentreStack_mem_alloc dflags = pc_OFFSET_CostCentreStack_mem_alloc (sPlatformConstants (settings dflags))-oFFSET_CostCentreStack_scc_count :: DynFlags -> Int-oFFSET_CostCentreStack_scc_count dflags = pc_OFFSET_CostCentreStack_scc_count (sPlatformConstants (settings dflags))-oFFSET_StgHeader_ccs :: DynFlags -> Int-oFFSET_StgHeader_ccs dflags = pc_OFFSET_StgHeader_ccs (sPlatformConstants (settings dflags))-oFFSET_StgHeader_ldvw :: DynFlags -> Int-oFFSET_StgHeader_ldvw dflags = pc_OFFSET_StgHeader_ldvw (sPlatformConstants (settings dflags))-sIZEOF_StgSMPThunkHeader :: DynFlags -> Int-sIZEOF_StgSMPThunkHeader dflags = pc_SIZEOF_StgSMPThunkHeader (sPlatformConstants (settings dflags))-oFFSET_StgEntCounter_allocs :: DynFlags -> Int-oFFSET_StgEntCounter_allocs dflags = pc_OFFSET_StgEntCounter_allocs (sPlatformConstants (settings dflags))-oFFSET_StgEntCounter_allocd :: DynFlags -> Int-oFFSET_StgEntCounter_allocd dflags = pc_OFFSET_StgEntCounter_allocd (sPlatformConstants (settings dflags))-oFFSET_StgEntCounter_registeredp :: DynFlags -> Int-oFFSET_StgEntCounter_registeredp dflags = pc_OFFSET_StgEntCounter_registeredp (sPlatformConstants (settings dflags))-oFFSET_StgEntCounter_link :: DynFlags -> Int-oFFSET_StgEntCounter_link dflags = pc_OFFSET_StgEntCounter_link (sPlatformConstants (settings dflags))-oFFSET_StgEntCounter_entry_count :: DynFlags -> Int-oFFSET_StgEntCounter_entry_count dflags = pc_OFFSET_StgEntCounter_entry_count (sPlatformConstants (settings dflags))-sIZEOF_StgUpdateFrame_NoHdr :: DynFlags -> Int-sIZEOF_StgUpdateFrame_NoHdr dflags = pc_SIZEOF_StgUpdateFrame_NoHdr (sPlatformConstants (settings dflags))-sIZEOF_StgMutArrPtrs_NoHdr :: DynFlags -> Int-sIZEOF_StgMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgMutArrPtrs_NoHdr (sPlatformConstants (settings dflags))-oFFSET_StgMutArrPtrs_ptrs :: DynFlags -> Int-oFFSET_StgMutArrPtrs_ptrs dflags = pc_OFFSET_StgMutArrPtrs_ptrs (sPlatformConstants (settings dflags))-oFFSET_StgMutArrPtrs_size :: DynFlags -> Int-oFFSET_StgMutArrPtrs_size dflags = pc_OFFSET_StgMutArrPtrs_size (sPlatformConstants (settings dflags))-sIZEOF_StgSmallMutArrPtrs_NoHdr :: DynFlags -> Int-sIZEOF_StgSmallMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgSmallMutArrPtrs_NoHdr (sPlatformConstants (settings dflags))-oFFSET_StgSmallMutArrPtrs_ptrs :: DynFlags -> Int-oFFSET_StgSmallMutArrPtrs_ptrs dflags = pc_OFFSET_StgSmallMutArrPtrs_ptrs (sPlatformConstants (settings dflags))-sIZEOF_StgArrBytes_NoHdr :: DynFlags -> Int-sIZEOF_StgArrBytes_NoHdr dflags = pc_SIZEOF_StgArrBytes_NoHdr (sPlatformConstants (settings dflags))-oFFSET_StgArrBytes_bytes :: DynFlags -> Int-oFFSET_StgArrBytes_bytes dflags = pc_OFFSET_StgArrBytes_bytes (sPlatformConstants (settings dflags))-oFFSET_StgTSO_alloc_limit :: DynFlags -> Int-oFFSET_StgTSO_alloc_limit dflags = pc_OFFSET_StgTSO_alloc_limit (sPlatformConstants (settings dflags))-oFFSET_StgTSO_cccs :: DynFlags -> Int-oFFSET_StgTSO_cccs dflags = pc_OFFSET_StgTSO_cccs (sPlatformConstants (settings dflags))-oFFSET_StgTSO_stackobj :: DynFlags -> Int-oFFSET_StgTSO_stackobj dflags = pc_OFFSET_StgTSO_stackobj (sPlatformConstants (settings dflags))-oFFSET_StgStack_sp :: DynFlags -> Int-oFFSET_StgStack_sp dflags = pc_OFFSET_StgStack_sp (sPlatformConstants (settings dflags))-oFFSET_StgStack_stack :: DynFlags -> Int-oFFSET_StgStack_stack dflags = pc_OFFSET_StgStack_stack (sPlatformConstants (settings dflags))-oFFSET_StgUpdateFrame_updatee :: DynFlags -> Int-oFFSET_StgUpdateFrame_updatee dflags = pc_OFFSET_StgUpdateFrame_updatee (sPlatformConstants (settings dflags))-oFFSET_StgFunInfoExtraFwd_arity :: DynFlags -> Int-oFFSET_StgFunInfoExtraFwd_arity dflags = pc_OFFSET_StgFunInfoExtraFwd_arity (sPlatformConstants (settings dflags))-sIZEOF_StgFunInfoExtraRev :: DynFlags -> Int-sIZEOF_StgFunInfoExtraRev dflags = pc_SIZEOF_StgFunInfoExtraRev (sPlatformConstants (settings dflags))-oFFSET_StgFunInfoExtraRev_arity :: DynFlags -> Int-oFFSET_StgFunInfoExtraRev_arity dflags = pc_OFFSET_StgFunInfoExtraRev_arity (sPlatformConstants (settings dflags))-mAX_SPEC_SELECTEE_SIZE :: DynFlags -> Int-mAX_SPEC_SELECTEE_SIZE dflags = pc_MAX_SPEC_SELECTEE_SIZE (sPlatformConstants (settings dflags))-mAX_SPEC_AP_SIZE :: DynFlags -> Int-mAX_SPEC_AP_SIZE dflags = pc_MAX_SPEC_AP_SIZE (sPlatformConstants (settings dflags))-mIN_PAYLOAD_SIZE :: DynFlags -> Int-mIN_PAYLOAD_SIZE dflags = pc_MIN_PAYLOAD_SIZE (sPlatformConstants (settings dflags))-mIN_INTLIKE :: DynFlags -> Int-mIN_INTLIKE dflags = pc_MIN_INTLIKE (sPlatformConstants (settings dflags))-mAX_INTLIKE :: DynFlags -> Int-mAX_INTLIKE dflags = pc_MAX_INTLIKE (sPlatformConstants (settings dflags))-mIN_CHARLIKE :: DynFlags -> Int-mIN_CHARLIKE dflags = pc_MIN_CHARLIKE (sPlatformConstants (settings dflags))-mAX_CHARLIKE :: DynFlags -> Int-mAX_CHARLIKE dflags = pc_MAX_CHARLIKE (sPlatformConstants (settings dflags))-mUT_ARR_PTRS_CARD_BITS :: DynFlags -> Int-mUT_ARR_PTRS_CARD_BITS dflags = pc_MUT_ARR_PTRS_CARD_BITS (sPlatformConstants (settings dflags))-mAX_Vanilla_REG :: DynFlags -> Int-mAX_Vanilla_REG dflags = pc_MAX_Vanilla_REG (sPlatformConstants (settings dflags))-mAX_Float_REG :: DynFlags -> Int-mAX_Float_REG dflags = pc_MAX_Float_REG (sPlatformConstants (settings dflags))-mAX_Double_REG :: DynFlags -> Int-mAX_Double_REG dflags = pc_MAX_Double_REG (sPlatformConstants (settings dflags))-mAX_Long_REG :: DynFlags -> Int-mAX_Long_REG dflags = pc_MAX_Long_REG (sPlatformConstants (settings dflags))-mAX_XMM_REG :: DynFlags -> Int-mAX_XMM_REG dflags = pc_MAX_XMM_REG (sPlatformConstants (settings dflags))-mAX_Real_Vanilla_REG :: DynFlags -> Int-mAX_Real_Vanilla_REG dflags = pc_MAX_Real_Vanilla_REG (sPlatformConstants (settings dflags))-mAX_Real_Float_REG :: DynFlags -> Int-mAX_Real_Float_REG dflags = pc_MAX_Real_Float_REG (sPlatformConstants (settings dflags))-mAX_Real_Double_REG :: DynFlags -> Int-mAX_Real_Double_REG dflags = pc_MAX_Real_Double_REG (sPlatformConstants (settings dflags))-mAX_Real_XMM_REG :: DynFlags -> Int-mAX_Real_XMM_REG dflags = pc_MAX_Real_XMM_REG (sPlatformConstants (settings dflags))-mAX_Real_Long_REG :: DynFlags -> Int-mAX_Real_Long_REG dflags = pc_MAX_Real_Long_REG (sPlatformConstants (settings dflags))-rESERVED_C_STACK_BYTES :: DynFlags -> Int-rESERVED_C_STACK_BYTES dflags = pc_RESERVED_C_STACK_BYTES (sPlatformConstants (settings dflags))-rESERVED_STACK_WORDS :: DynFlags -> Int-rESERVED_STACK_WORDS dflags = pc_RESERVED_STACK_WORDS (sPlatformConstants (settings dflags))-aP_STACK_SPLIM :: DynFlags -> Int-aP_STACK_SPLIM dflags = pc_AP_STACK_SPLIM (sPlatformConstants (settings dflags))-wORD_SIZE :: DynFlags -> Int-wORD_SIZE dflags = pc_WORD_SIZE (sPlatformConstants (settings dflags))-dOUBLE_SIZE :: DynFlags -> Int-dOUBLE_SIZE dflags = pc_DOUBLE_SIZE (sPlatformConstants (settings dflags))-cINT_SIZE :: DynFlags -> Int-cINT_SIZE dflags = pc_CINT_SIZE (sPlatformConstants (settings dflags))-cLONG_SIZE :: DynFlags -> Int-cLONG_SIZE dflags = pc_CLONG_SIZE (sPlatformConstants (settings dflags))-cLONG_LONG_SIZE :: DynFlags -> Int-cLONG_LONG_SIZE dflags = pc_CLONG_LONG_SIZE (sPlatformConstants (settings dflags))-bITMAP_BITS_SHIFT :: DynFlags -> Int-bITMAP_BITS_SHIFT dflags = pc_BITMAP_BITS_SHIFT (sPlatformConstants (settings dflags))-tAG_BITS :: DynFlags -> Int-tAG_BITS dflags = pc_TAG_BITS (sPlatformConstants (settings dflags))-wORDS_BIGENDIAN :: DynFlags -> Bool-wORDS_BIGENDIAN dflags = pc_WORDS_BIGENDIAN (sPlatformConstants (settings dflags))-dYNAMIC_BY_DEFAULT :: DynFlags -> Bool-dYNAMIC_BY_DEFAULT dflags = pc_DYNAMIC_BY_DEFAULT (sPlatformConstants (settings dflags))-lDV_SHIFT :: DynFlags -> Int-lDV_SHIFT dflags = pc_LDV_SHIFT (sPlatformConstants (settings dflags))-iLDV_CREATE_MASK :: DynFlags -> Integer-iLDV_CREATE_MASK dflags = pc_ILDV_CREATE_MASK (sPlatformConstants (settings dflags))-iLDV_STATE_CREATE :: DynFlags -> Integer-iLDV_STATE_CREATE dflags = pc_ILDV_STATE_CREATE (sPlatformConstants (settings dflags))-iLDV_STATE_USE :: DynFlags -> Integer-iLDV_STATE_USE dflags = pc_ILDV_STATE_USE (sPlatformConstants (settings dflags))
− ghc-lib/generated/GhclibDerivedConstants.h 
@@ -1,554 +0,0 @@-/* This file is created automatically.  Do not edit by hand.*/--#define CONTROL_GROUP_CONST_291 291-#define STD_HDR_SIZE 1-#define PROF_HDR_SIZE 2-#define BLOCK_SIZE 4096-#define MBLOCK_SIZE 1048576-#define BLOCKS_PER_MBLOCK 252-#define TICKY_BIN_COUNT 9-#define OFFSET_StgRegTable_rR1 0-#define OFFSET_StgRegTable_rR2 8-#define OFFSET_StgRegTable_rR3 16-#define OFFSET_StgRegTable_rR4 24-#define OFFSET_StgRegTable_rR5 32-#define OFFSET_StgRegTable_rR6 40-#define OFFSET_StgRegTable_rR7 48-#define OFFSET_StgRegTable_rR8 56-#define OFFSET_StgRegTable_rR9 64-#define OFFSET_StgRegTable_rR10 72-#define OFFSET_StgRegTable_rF1 80-#define OFFSET_StgRegTable_rF2 84-#define OFFSET_StgRegTable_rF3 88-#define OFFSET_StgRegTable_rF4 92-#define OFFSET_StgRegTable_rF5 96-#define OFFSET_StgRegTable_rF6 100-#define OFFSET_StgRegTable_rD1 104-#define OFFSET_StgRegTable_rD2 112-#define OFFSET_StgRegTable_rD3 120-#define OFFSET_StgRegTable_rD4 128-#define OFFSET_StgRegTable_rD5 136-#define OFFSET_StgRegTable_rD6 144-#define OFFSET_StgRegTable_rXMM1 152-#define OFFSET_StgRegTable_rXMM2 168-#define OFFSET_StgRegTable_rXMM3 184-#define OFFSET_StgRegTable_rXMM4 200-#define OFFSET_StgRegTable_rXMM5 216-#define OFFSET_StgRegTable_rXMM6 232-#define OFFSET_StgRegTable_rYMM1 248-#define OFFSET_StgRegTable_rYMM2 280-#define OFFSET_StgRegTable_rYMM3 312-#define OFFSET_StgRegTable_rYMM4 344-#define OFFSET_StgRegTable_rYMM5 376-#define OFFSET_StgRegTable_rYMM6 408-#define OFFSET_StgRegTable_rZMM1 440-#define OFFSET_StgRegTable_rZMM2 504-#define OFFSET_StgRegTable_rZMM3 568-#define OFFSET_StgRegTable_rZMM4 632-#define OFFSET_StgRegTable_rZMM5 696-#define OFFSET_StgRegTable_rZMM6 760-#define OFFSET_StgRegTable_rL1 824-#define OFFSET_StgRegTable_rSp 832-#define OFFSET_StgRegTable_rSpLim 840-#define OFFSET_StgRegTable_rHp 848-#define OFFSET_StgRegTable_rHpLim 856-#define OFFSET_StgRegTable_rCCCS 864-#define OFFSET_StgRegTable_rCurrentTSO 872-#define OFFSET_StgRegTable_rCurrentNursery 888-#define OFFSET_StgRegTable_rHpAlloc 904-#define OFFSET_StgRegTable_rRet 912-#define REP_StgRegTable_rRet b64-#define StgRegTable_rRet(__ptr__) REP_StgRegTable_rRet[__ptr__+OFFSET_StgRegTable_rRet]-#define OFFSET_StgRegTable_rNursery 880-#define REP_StgRegTable_rNursery b64-#define StgRegTable_rNursery(__ptr__) REP_StgRegTable_rNursery[__ptr__+OFFSET_StgRegTable_rNursery]-#define OFFSET_stgEagerBlackholeInfo -24-#define OFFSET_stgGCEnter1 -16-#define OFFSET_stgGCFun -8-#define OFFSET_Capability_r 24-#define OFFSET_Capability_lock 1096-#define OFFSET_Capability_no 944-#define REP_Capability_no b32-#define Capability_no(__ptr__) REP_Capability_no[__ptr__+OFFSET_Capability_no]-#define OFFSET_Capability_mut_lists 1016-#define REP_Capability_mut_lists b64-#define Capability_mut_lists(__ptr__) REP_Capability_mut_lists[__ptr__+OFFSET_Capability_mut_lists]-#define OFFSET_Capability_context_switch 1064-#define REP_Capability_context_switch b32-#define Capability_context_switch(__ptr__) REP_Capability_context_switch[__ptr__+OFFSET_Capability_context_switch]-#define OFFSET_Capability_interrupt 1068-#define REP_Capability_interrupt b32-#define Capability_interrupt(__ptr__) REP_Capability_interrupt[__ptr__+OFFSET_Capability_interrupt]-#define OFFSET_Capability_sparks 1200-#define REP_Capability_sparks b64-#define Capability_sparks(__ptr__) REP_Capability_sparks[__ptr__+OFFSET_Capability_sparks]-#define OFFSET_Capability_total_allocated 1072-#define REP_Capability_total_allocated b64-#define Capability_total_allocated(__ptr__) REP_Capability_total_allocated[__ptr__+OFFSET_Capability_total_allocated]-#define OFFSET_Capability_weak_ptr_list_hd 1048-#define REP_Capability_weak_ptr_list_hd b64-#define Capability_weak_ptr_list_hd(__ptr__) REP_Capability_weak_ptr_list_hd[__ptr__+OFFSET_Capability_weak_ptr_list_hd]-#define OFFSET_Capability_weak_ptr_list_tl 1056-#define REP_Capability_weak_ptr_list_tl b64-#define Capability_weak_ptr_list_tl(__ptr__) REP_Capability_weak_ptr_list_tl[__ptr__+OFFSET_Capability_weak_ptr_list_tl]-#define OFFSET_bdescr_start 0-#define REP_bdescr_start b64-#define bdescr_start(__ptr__) REP_bdescr_start[__ptr__+OFFSET_bdescr_start]-#define OFFSET_bdescr_free 8-#define REP_bdescr_free b64-#define bdescr_free(__ptr__) REP_bdescr_free[__ptr__+OFFSET_bdescr_free]-#define OFFSET_bdescr_blocks 48-#define REP_bdescr_blocks b32-#define bdescr_blocks(__ptr__) REP_bdescr_blocks[__ptr__+OFFSET_bdescr_blocks]-#define OFFSET_bdescr_gen_no 40-#define REP_bdescr_gen_no b16-#define bdescr_gen_no(__ptr__) REP_bdescr_gen_no[__ptr__+OFFSET_bdescr_gen_no]-#define OFFSET_bdescr_link 16-#define REP_bdescr_link b64-#define bdescr_link(__ptr__) REP_bdescr_link[__ptr__+OFFSET_bdescr_link]-#define OFFSET_bdescr_flags 46-#define REP_bdescr_flags b16-#define bdescr_flags(__ptr__) REP_bdescr_flags[__ptr__+OFFSET_bdescr_flags]-#define SIZEOF_generation 384-#define OFFSET_generation_n_new_large_words 56-#define REP_generation_n_new_large_words b64-#define generation_n_new_large_words(__ptr__) REP_generation_n_new_large_words[__ptr__+OFFSET_generation_n_new_large_words]-#define OFFSET_generation_weak_ptr_list 112-#define REP_generation_weak_ptr_list b64-#define generation_weak_ptr_list(__ptr__) REP_generation_weak_ptr_list[__ptr__+OFFSET_generation_weak_ptr_list]-#define SIZEOF_CostCentreStack 96-#define OFFSET_CostCentreStack_ccsID 0-#define REP_CostCentreStack_ccsID b64-#define CostCentreStack_ccsID(__ptr__) REP_CostCentreStack_ccsID[__ptr__+OFFSET_CostCentreStack_ccsID]-#define OFFSET_CostCentreStack_mem_alloc 72-#define REP_CostCentreStack_mem_alloc b64-#define CostCentreStack_mem_alloc(__ptr__) REP_CostCentreStack_mem_alloc[__ptr__+OFFSET_CostCentreStack_mem_alloc]-#define OFFSET_CostCentreStack_scc_count 48-#define REP_CostCentreStack_scc_count b64-#define CostCentreStack_scc_count(__ptr__) REP_CostCentreStack_scc_count[__ptr__+OFFSET_CostCentreStack_scc_count]-#define OFFSET_CostCentreStack_prevStack 16-#define REP_CostCentreStack_prevStack b64-#define CostCentreStack_prevStack(__ptr__) REP_CostCentreStack_prevStack[__ptr__+OFFSET_CostCentreStack_prevStack]-#define OFFSET_CostCentre_ccID 0-#define REP_CostCentre_ccID b64-#define CostCentre_ccID(__ptr__) REP_CostCentre_ccID[__ptr__+OFFSET_CostCentre_ccID]-#define OFFSET_CostCentre_link 56-#define REP_CostCentre_link b64-#define CostCentre_link(__ptr__) REP_CostCentre_link[__ptr__+OFFSET_CostCentre_link]-#define OFFSET_StgHeader_info 0-#define REP_StgHeader_info b64-#define StgHeader_info(__ptr__) REP_StgHeader_info[__ptr__+OFFSET_StgHeader_info]-#define OFFSET_StgHeader_ccs 8-#define REP_StgHeader_ccs b64-#define StgHeader_ccs(__ptr__) REP_StgHeader_ccs[__ptr__+OFFSET_StgHeader_ccs]-#define OFFSET_StgHeader_ldvw 16-#define REP_StgHeader_ldvw b64-#define StgHeader_ldvw(__ptr__) REP_StgHeader_ldvw[__ptr__+OFFSET_StgHeader_ldvw]-#define SIZEOF_StgSMPThunkHeader 8-#define OFFSET_StgClosure_payload 0-#define StgClosure_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgClosure_payload + WDS(__ix__)]-#define OFFSET_StgEntCounter_allocs 48-#define REP_StgEntCounter_allocs b64-#define StgEntCounter_allocs(__ptr__) REP_StgEntCounter_allocs[__ptr__+OFFSET_StgEntCounter_allocs]-#define OFFSET_StgEntCounter_allocd 16-#define REP_StgEntCounter_allocd b64-#define StgEntCounter_allocd(__ptr__) REP_StgEntCounter_allocd[__ptr__+OFFSET_StgEntCounter_allocd]-#define OFFSET_StgEntCounter_registeredp 0-#define REP_StgEntCounter_registeredp b64-#define StgEntCounter_registeredp(__ptr__) REP_StgEntCounter_registeredp[__ptr__+OFFSET_StgEntCounter_registeredp]-#define OFFSET_StgEntCounter_link 56-#define REP_StgEntCounter_link b64-#define StgEntCounter_link(__ptr__) REP_StgEntCounter_link[__ptr__+OFFSET_StgEntCounter_link]-#define OFFSET_StgEntCounter_entry_count 40-#define REP_StgEntCounter_entry_count b64-#define StgEntCounter_entry_count(__ptr__) REP_StgEntCounter_entry_count[__ptr__+OFFSET_StgEntCounter_entry_count]-#define SIZEOF_StgUpdateFrame_NoHdr 8-#define SIZEOF_StgUpdateFrame (SIZEOF_StgHeader+8)-#define SIZEOF_StgCatchFrame_NoHdr 16-#define SIZEOF_StgCatchFrame (SIZEOF_StgHeader+16)-#define SIZEOF_StgStopFrame_NoHdr 0-#define SIZEOF_StgStopFrame (SIZEOF_StgHeader+0)-#define SIZEOF_StgMutArrPtrs_NoHdr 16-#define SIZEOF_StgMutArrPtrs (SIZEOF_StgHeader+16)-#define OFFSET_StgMutArrPtrs_ptrs 0-#define REP_StgMutArrPtrs_ptrs b64-#define StgMutArrPtrs_ptrs(__ptr__) REP_StgMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_ptrs]-#define OFFSET_StgMutArrPtrs_size 8-#define REP_StgMutArrPtrs_size b64-#define StgMutArrPtrs_size(__ptr__) REP_StgMutArrPtrs_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_size]-#define SIZEOF_StgSmallMutArrPtrs_NoHdr 8-#define SIZEOF_StgSmallMutArrPtrs (SIZEOF_StgHeader+8)-#define OFFSET_StgSmallMutArrPtrs_ptrs 0-#define REP_StgSmallMutArrPtrs_ptrs b64-#define StgSmallMutArrPtrs_ptrs(__ptr__) REP_StgSmallMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgSmallMutArrPtrs_ptrs]-#define SIZEOF_StgArrBytes_NoHdr 8-#define SIZEOF_StgArrBytes (SIZEOF_StgHeader+8)-#define OFFSET_StgArrBytes_bytes 0-#define REP_StgArrBytes_bytes b64-#define StgArrBytes_bytes(__ptr__) REP_StgArrBytes_bytes[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_bytes]-#define OFFSET_StgArrBytes_payload 8-#define StgArrBytes_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_payload + WDS(__ix__)]-#define OFFSET_StgTSO__link 0-#define REP_StgTSO__link b64-#define StgTSO__link(__ptr__) REP_StgTSO__link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO__link]-#define OFFSET_StgTSO_global_link 8-#define REP_StgTSO_global_link b64-#define StgTSO_global_link(__ptr__) REP_StgTSO_global_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_global_link]-#define OFFSET_StgTSO_what_next 24-#define REP_StgTSO_what_next b16-#define StgTSO_what_next(__ptr__) REP_StgTSO_what_next[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_what_next]-#define OFFSET_StgTSO_why_blocked 26-#define REP_StgTSO_why_blocked b16-#define StgTSO_why_blocked(__ptr__) REP_StgTSO_why_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_why_blocked]-#define OFFSET_StgTSO_block_info 32-#define REP_StgTSO_block_info b64-#define StgTSO_block_info(__ptr__) REP_StgTSO_block_info[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_block_info]-#define OFFSET_StgTSO_blocked_exceptions 80-#define REP_StgTSO_blocked_exceptions b64-#define StgTSO_blocked_exceptions(__ptr__) REP_StgTSO_blocked_exceptions[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_blocked_exceptions]-#define OFFSET_StgTSO_id 40-#define REP_StgTSO_id b32-#define StgTSO_id(__ptr__) REP_StgTSO_id[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_id]-#define OFFSET_StgTSO_cap 64-#define REP_StgTSO_cap b64-#define StgTSO_cap(__ptr__) REP_StgTSO_cap[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cap]-#define OFFSET_StgTSO_saved_errno 44-#define REP_StgTSO_saved_errno b32-#define StgTSO_saved_errno(__ptr__) REP_StgTSO_saved_errno[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_saved_errno]-#define OFFSET_StgTSO_trec 72-#define REP_StgTSO_trec b64-#define StgTSO_trec(__ptr__) REP_StgTSO_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_trec]-#define OFFSET_StgTSO_flags 28-#define REP_StgTSO_flags b32-#define StgTSO_flags(__ptr__) REP_StgTSO_flags[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_flags]-#define OFFSET_StgTSO_dirty 48-#define REP_StgTSO_dirty b32-#define StgTSO_dirty(__ptr__) REP_StgTSO_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_dirty]-#define OFFSET_StgTSO_bq 88-#define REP_StgTSO_bq b64-#define StgTSO_bq(__ptr__) REP_StgTSO_bq[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_bq]-#define OFFSET_StgTSO_alloc_limit 96-#define REP_StgTSO_alloc_limit b64-#define StgTSO_alloc_limit(__ptr__) REP_StgTSO_alloc_limit[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_alloc_limit]-#define OFFSET_StgTSO_cccs 112-#define REP_StgTSO_cccs b64-#define StgTSO_cccs(__ptr__) REP_StgTSO_cccs[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cccs]-#define OFFSET_StgTSO_stackobj 16-#define REP_StgTSO_stackobj b64-#define StgTSO_stackobj(__ptr__) REP_StgTSO_stackobj[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_stackobj]-#define OFFSET_StgStack_sp 8-#define REP_StgStack_sp b64-#define StgStack_sp(__ptr__) REP_StgStack_sp[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_sp]-#define OFFSET_StgStack_stack 16-#define OFFSET_StgStack_stack_size 0-#define REP_StgStack_stack_size b32-#define StgStack_stack_size(__ptr__) REP_StgStack_stack_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_stack_size]-#define OFFSET_StgStack_dirty 4-#define REP_StgStack_dirty b32-#define StgStack_dirty(__ptr__) REP_StgStack_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_dirty]-#define SIZEOF_StgTSOProfInfo 8-#define OFFSET_StgUpdateFrame_updatee 0-#define REP_StgUpdateFrame_updatee b64-#define StgUpdateFrame_updatee(__ptr__) REP_StgUpdateFrame_updatee[__ptr__+SIZEOF_StgHeader+OFFSET_StgUpdateFrame_updatee]-#define OFFSET_StgCatchFrame_handler 8-#define REP_StgCatchFrame_handler b64-#define StgCatchFrame_handler(__ptr__) REP_StgCatchFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_handler]-#define OFFSET_StgCatchFrame_exceptions_blocked 0-#define REP_StgCatchFrame_exceptions_blocked b64-#define StgCatchFrame_exceptions_blocked(__ptr__) REP_StgCatchFrame_exceptions_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_exceptions_blocked]-#define SIZEOF_StgPAP_NoHdr 16-#define SIZEOF_StgPAP (SIZEOF_StgHeader+16)-#define OFFSET_StgPAP_n_args 4-#define REP_StgPAP_n_args b32-#define StgPAP_n_args(__ptr__) REP_StgPAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_n_args]-#define OFFSET_StgPAP_fun 8-#define REP_StgPAP_fun gcptr-#define StgPAP_fun(__ptr__) REP_StgPAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_fun]-#define OFFSET_StgPAP_arity 0-#define REP_StgPAP_arity b32-#define StgPAP_arity(__ptr__) REP_StgPAP_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_arity]-#define OFFSET_StgPAP_payload 16-#define StgPAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_payload + WDS(__ix__)]-#define SIZEOF_StgAP_NoThunkHdr 16-#define SIZEOF_StgAP_NoHdr 24-#define SIZEOF_StgAP (SIZEOF_StgHeader+24)-#define OFFSET_StgAP_n_args 12-#define REP_StgAP_n_args b32-#define StgAP_n_args(__ptr__) REP_StgAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_n_args]-#define OFFSET_StgAP_fun 16-#define REP_StgAP_fun gcptr-#define StgAP_fun(__ptr__) REP_StgAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_fun]-#define OFFSET_StgAP_payload 24-#define StgAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_payload + WDS(__ix__)]-#define SIZEOF_StgAP_STACK_NoThunkHdr 16-#define SIZEOF_StgAP_STACK_NoHdr 24-#define SIZEOF_StgAP_STACK (SIZEOF_StgHeader+24)-#define OFFSET_StgAP_STACK_size 8-#define REP_StgAP_STACK_size b64-#define StgAP_STACK_size(__ptr__) REP_StgAP_STACK_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_size]-#define OFFSET_StgAP_STACK_fun 16-#define REP_StgAP_STACK_fun gcptr-#define StgAP_STACK_fun(__ptr__) REP_StgAP_STACK_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_fun]-#define OFFSET_StgAP_STACK_payload 24-#define StgAP_STACK_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_payload + WDS(__ix__)]-#define SIZEOF_StgSelector_NoThunkHdr 8-#define SIZEOF_StgSelector_NoHdr 16-#define SIZEOF_StgSelector (SIZEOF_StgHeader+16)-#define OFFSET_StgInd_indirectee 0-#define REP_StgInd_indirectee gcptr-#define StgInd_indirectee(__ptr__) REP_StgInd_indirectee[__ptr__+SIZEOF_StgHeader+OFFSET_StgInd_indirectee]-#define SIZEOF_StgMutVar_NoHdr 8-#define SIZEOF_StgMutVar (SIZEOF_StgHeader+8)-#define OFFSET_StgMutVar_var 0-#define REP_StgMutVar_var b64-#define StgMutVar_var(__ptr__) REP_StgMutVar_var[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutVar_var]-#define SIZEOF_StgAtomicallyFrame_NoHdr 16-#define SIZEOF_StgAtomicallyFrame (SIZEOF_StgHeader+16)-#define OFFSET_StgAtomicallyFrame_code 0-#define REP_StgAtomicallyFrame_code b64-#define StgAtomicallyFrame_code(__ptr__) REP_StgAtomicallyFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_code]-#define OFFSET_StgAtomicallyFrame_result 8-#define REP_StgAtomicallyFrame_result b64-#define StgAtomicallyFrame_result(__ptr__) REP_StgAtomicallyFrame_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_result]-#define OFFSET_StgTRecHeader_enclosing_trec 0-#define REP_StgTRecHeader_enclosing_trec b64-#define StgTRecHeader_enclosing_trec(__ptr__) REP_StgTRecHeader_enclosing_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTRecHeader_enclosing_trec]-#define SIZEOF_StgCatchSTMFrame_NoHdr 16-#define SIZEOF_StgCatchSTMFrame (SIZEOF_StgHeader+16)-#define OFFSET_StgCatchSTMFrame_handler 8-#define REP_StgCatchSTMFrame_handler b64-#define StgCatchSTMFrame_handler(__ptr__) REP_StgCatchSTMFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_handler]-#define OFFSET_StgCatchSTMFrame_code 0-#define REP_StgCatchSTMFrame_code b64-#define StgCatchSTMFrame_code(__ptr__) REP_StgCatchSTMFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_code]-#define SIZEOF_StgCatchRetryFrame_NoHdr 24-#define SIZEOF_StgCatchRetryFrame (SIZEOF_StgHeader+24)-#define OFFSET_StgCatchRetryFrame_running_alt_code 0-#define REP_StgCatchRetryFrame_running_alt_code b64-#define StgCatchRetryFrame_running_alt_code(__ptr__) REP_StgCatchRetryFrame_running_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_running_alt_code]-#define OFFSET_StgCatchRetryFrame_first_code 8-#define REP_StgCatchRetryFrame_first_code b64-#define StgCatchRetryFrame_first_code(__ptr__) REP_StgCatchRetryFrame_first_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_first_code]-#define OFFSET_StgCatchRetryFrame_alt_code 16-#define REP_StgCatchRetryFrame_alt_code b64-#define StgCatchRetryFrame_alt_code(__ptr__) REP_StgCatchRetryFrame_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_alt_code]-#define OFFSET_StgTVarWatchQueue_closure 0-#define REP_StgTVarWatchQueue_closure b64-#define StgTVarWatchQueue_closure(__ptr__) REP_StgTVarWatchQueue_closure[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_closure]-#define OFFSET_StgTVarWatchQueue_next_queue_entry 8-#define REP_StgTVarWatchQueue_next_queue_entry b64-#define StgTVarWatchQueue_next_queue_entry(__ptr__) REP_StgTVarWatchQueue_next_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_next_queue_entry]-#define OFFSET_StgTVarWatchQueue_prev_queue_entry 16-#define REP_StgTVarWatchQueue_prev_queue_entry b64-#define StgTVarWatchQueue_prev_queue_entry(__ptr__) REP_StgTVarWatchQueue_prev_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_prev_queue_entry]-#define SIZEOF_StgTVar_NoHdr 24-#define SIZEOF_StgTVar (SIZEOF_StgHeader+24)-#define OFFSET_StgTVar_current_value 0-#define REP_StgTVar_current_value b64-#define StgTVar_current_value(__ptr__) REP_StgTVar_current_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_current_value]-#define OFFSET_StgTVar_first_watch_queue_entry 8-#define REP_StgTVar_first_watch_queue_entry b64-#define StgTVar_first_watch_queue_entry(__ptr__) REP_StgTVar_first_watch_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_first_watch_queue_entry]-#define OFFSET_StgTVar_num_updates 16-#define REP_StgTVar_num_updates b64-#define StgTVar_num_updates(__ptr__) REP_StgTVar_num_updates[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_num_updates]-#define SIZEOF_StgWeak_NoHdr 40-#define SIZEOF_StgWeak (SIZEOF_StgHeader+40)-#define OFFSET_StgWeak_link 32-#define REP_StgWeak_link b64-#define StgWeak_link(__ptr__) REP_StgWeak_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_link]-#define OFFSET_StgWeak_key 8-#define REP_StgWeak_key b64-#define StgWeak_key(__ptr__) REP_StgWeak_key[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_key]-#define OFFSET_StgWeak_value 16-#define REP_StgWeak_value b64-#define StgWeak_value(__ptr__) REP_StgWeak_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_value]-#define OFFSET_StgWeak_finalizer 24-#define REP_StgWeak_finalizer b64-#define StgWeak_finalizer(__ptr__) REP_StgWeak_finalizer[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_finalizer]-#define OFFSET_StgWeak_cfinalizers 0-#define REP_StgWeak_cfinalizers b64-#define StgWeak_cfinalizers(__ptr__) REP_StgWeak_cfinalizers[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_cfinalizers]-#define SIZEOF_StgCFinalizerList_NoHdr 40-#define SIZEOF_StgCFinalizerList (SIZEOF_StgHeader+40)-#define OFFSET_StgCFinalizerList_link 0-#define REP_StgCFinalizerList_link b64-#define StgCFinalizerList_link(__ptr__) REP_StgCFinalizerList_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_link]-#define OFFSET_StgCFinalizerList_fptr 8-#define REP_StgCFinalizerList_fptr b64-#define StgCFinalizerList_fptr(__ptr__) REP_StgCFinalizerList_fptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_fptr]-#define OFFSET_StgCFinalizerList_ptr 16-#define REP_StgCFinalizerList_ptr b64-#define StgCFinalizerList_ptr(__ptr__) REP_StgCFinalizerList_ptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_ptr]-#define OFFSET_StgCFinalizerList_eptr 24-#define REP_StgCFinalizerList_eptr b64-#define StgCFinalizerList_eptr(__ptr__) REP_StgCFinalizerList_eptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_eptr]-#define OFFSET_StgCFinalizerList_flag 32-#define REP_StgCFinalizerList_flag b64-#define StgCFinalizerList_flag(__ptr__) REP_StgCFinalizerList_flag[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_flag]-#define SIZEOF_StgMVar_NoHdr 24-#define SIZEOF_StgMVar (SIZEOF_StgHeader+24)-#define OFFSET_StgMVar_head 0-#define REP_StgMVar_head b64-#define StgMVar_head(__ptr__) REP_StgMVar_head[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_head]-#define OFFSET_StgMVar_tail 8-#define REP_StgMVar_tail b64-#define StgMVar_tail(__ptr__) REP_StgMVar_tail[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_tail]-#define OFFSET_StgMVar_value 16-#define REP_StgMVar_value b64-#define StgMVar_value(__ptr__) REP_StgMVar_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_value]-#define SIZEOF_StgMVarTSOQueue_NoHdr 16-#define SIZEOF_StgMVarTSOQueue (SIZEOF_StgHeader+16)-#define OFFSET_StgMVarTSOQueue_link 0-#define REP_StgMVarTSOQueue_link b64-#define StgMVarTSOQueue_link(__ptr__) REP_StgMVarTSOQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_link]-#define OFFSET_StgMVarTSOQueue_tso 8-#define REP_StgMVarTSOQueue_tso b64-#define StgMVarTSOQueue_tso(__ptr__) REP_StgMVarTSOQueue_tso[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_tso]-#define SIZEOF_StgBCO_NoHdr 32-#define SIZEOF_StgBCO (SIZEOF_StgHeader+32)-#define OFFSET_StgBCO_instrs 0-#define REP_StgBCO_instrs b64-#define StgBCO_instrs(__ptr__) REP_StgBCO_instrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_instrs]-#define OFFSET_StgBCO_literals 8-#define REP_StgBCO_literals b64-#define StgBCO_literals(__ptr__) REP_StgBCO_literals[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_literals]-#define OFFSET_StgBCO_ptrs 16-#define REP_StgBCO_ptrs b64-#define StgBCO_ptrs(__ptr__) REP_StgBCO_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_ptrs]-#define OFFSET_StgBCO_arity 24-#define REP_StgBCO_arity b32-#define StgBCO_arity(__ptr__) REP_StgBCO_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_arity]-#define OFFSET_StgBCO_size 28-#define REP_StgBCO_size b32-#define StgBCO_size(__ptr__) REP_StgBCO_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_size]-#define OFFSET_StgBCO_bitmap 32-#define StgBCO_bitmap(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_bitmap + WDS(__ix__)]-#define SIZEOF_StgStableName_NoHdr 8-#define SIZEOF_StgStableName (SIZEOF_StgHeader+8)-#define OFFSET_StgStableName_sn 0-#define REP_StgStableName_sn b64-#define StgStableName_sn(__ptr__) REP_StgStableName_sn[__ptr__+SIZEOF_StgHeader+OFFSET_StgStableName_sn]-#define SIZEOF_StgBlockingQueue_NoHdr 32-#define SIZEOF_StgBlockingQueue (SIZEOF_StgHeader+32)-#define OFFSET_StgBlockingQueue_bh 8-#define REP_StgBlockingQueue_bh b64-#define StgBlockingQueue_bh(__ptr__) REP_StgBlockingQueue_bh[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_bh]-#define OFFSET_StgBlockingQueue_owner 16-#define REP_StgBlockingQueue_owner b64-#define StgBlockingQueue_owner(__ptr__) REP_StgBlockingQueue_owner[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_owner]-#define OFFSET_StgBlockingQueue_queue 24-#define REP_StgBlockingQueue_queue b64-#define StgBlockingQueue_queue(__ptr__) REP_StgBlockingQueue_queue[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_queue]-#define OFFSET_StgBlockingQueue_link 0-#define REP_StgBlockingQueue_link b64-#define StgBlockingQueue_link(__ptr__) REP_StgBlockingQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_link]-#define SIZEOF_MessageBlackHole_NoHdr 24-#define SIZEOF_MessageBlackHole (SIZEOF_StgHeader+24)-#define OFFSET_MessageBlackHole_link 0-#define REP_MessageBlackHole_link b64-#define MessageBlackHole_link(__ptr__) REP_MessageBlackHole_link[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_link]-#define OFFSET_MessageBlackHole_tso 8-#define REP_MessageBlackHole_tso b64-#define MessageBlackHole_tso(__ptr__) REP_MessageBlackHole_tso[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_tso]-#define OFFSET_MessageBlackHole_bh 16-#define REP_MessageBlackHole_bh b64-#define MessageBlackHole_bh(__ptr__) REP_MessageBlackHole_bh[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_bh]-#define SIZEOF_StgCompactNFData_NoHdr 64-#define SIZEOF_StgCompactNFData (SIZEOF_StgHeader+64)-#define OFFSET_StgCompactNFData_totalW 0-#define REP_StgCompactNFData_totalW b64-#define StgCompactNFData_totalW(__ptr__) REP_StgCompactNFData_totalW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_totalW]-#define OFFSET_StgCompactNFData_autoBlockW 8-#define REP_StgCompactNFData_autoBlockW b64-#define StgCompactNFData_autoBlockW(__ptr__) REP_StgCompactNFData_autoBlockW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_autoBlockW]-#define OFFSET_StgCompactNFData_nursery 32-#define REP_StgCompactNFData_nursery b64-#define StgCompactNFData_nursery(__ptr__) REP_StgCompactNFData_nursery[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_nursery]-#define OFFSET_StgCompactNFData_last 40-#define REP_StgCompactNFData_last b64-#define StgCompactNFData_last(__ptr__) REP_StgCompactNFData_last[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_last]-#define OFFSET_StgCompactNFData_hp 16-#define REP_StgCompactNFData_hp b64-#define StgCompactNFData_hp(__ptr__) REP_StgCompactNFData_hp[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hp]-#define OFFSET_StgCompactNFData_hpLim 24-#define REP_StgCompactNFData_hpLim b64-#define StgCompactNFData_hpLim(__ptr__) REP_StgCompactNFData_hpLim[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hpLim]-#define OFFSET_StgCompactNFData_hash 48-#define REP_StgCompactNFData_hash b64-#define StgCompactNFData_hash(__ptr__) REP_StgCompactNFData_hash[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hash]-#define OFFSET_StgCompactNFData_result 56-#define REP_StgCompactNFData_result b64-#define StgCompactNFData_result(__ptr__) REP_StgCompactNFData_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_result]-#define SIZEOF_StgCompactNFDataBlock 24-#define OFFSET_StgCompactNFDataBlock_self 0-#define REP_StgCompactNFDataBlock_self b64-#define StgCompactNFDataBlock_self(__ptr__) REP_StgCompactNFDataBlock_self[__ptr__+OFFSET_StgCompactNFDataBlock_self]-#define OFFSET_StgCompactNFDataBlock_owner 8-#define REP_StgCompactNFDataBlock_owner b64-#define StgCompactNFDataBlock_owner(__ptr__) REP_StgCompactNFDataBlock_owner[__ptr__+OFFSET_StgCompactNFDataBlock_owner]-#define OFFSET_StgCompactNFDataBlock_next 16-#define REP_StgCompactNFDataBlock_next b64-#define StgCompactNFDataBlock_next(__ptr__) REP_StgCompactNFDataBlock_next[__ptr__+OFFSET_StgCompactNFDataBlock_next]-#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 269-#define REP_RtsFlags_ProfFlags_showCCSOnException b8-#define RtsFlags_ProfFlags_showCCSOnException(__ptr__) REP_RtsFlags_ProfFlags_showCCSOnException[__ptr__+OFFSET_RtsFlags_ProfFlags_showCCSOnException]-#define OFFSET_RtsFlags_DebugFlags_apply 210-#define REP_RtsFlags_DebugFlags_apply b8-#define RtsFlags_DebugFlags_apply(__ptr__) REP_RtsFlags_DebugFlags_apply[__ptr__+OFFSET_RtsFlags_DebugFlags_apply]-#define OFFSET_RtsFlags_DebugFlags_sanity 206-#define REP_RtsFlags_DebugFlags_sanity b8-#define RtsFlags_DebugFlags_sanity(__ptr__) REP_RtsFlags_DebugFlags_sanity[__ptr__+OFFSET_RtsFlags_DebugFlags_sanity]-#define OFFSET_RtsFlags_DebugFlags_weak 202-#define REP_RtsFlags_DebugFlags_weak b8-#define RtsFlags_DebugFlags_weak(__ptr__) REP_RtsFlags_DebugFlags_weak[__ptr__+OFFSET_RtsFlags_DebugFlags_weak]-#define OFFSET_RtsFlags_GcFlags_initialStkSize 16-#define REP_RtsFlags_GcFlags_initialStkSize b32-#define RtsFlags_GcFlags_initialStkSize(__ptr__) REP_RtsFlags_GcFlags_initialStkSize[__ptr__+OFFSET_RtsFlags_GcFlags_initialStkSize]-#define OFFSET_RtsFlags_MiscFlags_tickInterval 176-#define REP_RtsFlags_MiscFlags_tickInterval b64-#define RtsFlags_MiscFlags_tickInterval(__ptr__) REP_RtsFlags_MiscFlags_tickInterval[__ptr__+OFFSET_RtsFlags_MiscFlags_tickInterval]-#define SIZEOF_StgFunInfoExtraFwd 32-#define OFFSET_StgFunInfoExtraFwd_slow_apply 24-#define REP_StgFunInfoExtraFwd_slow_apply b64-#define StgFunInfoExtraFwd_slow_apply(__ptr__) REP_StgFunInfoExtraFwd_slow_apply[__ptr__+OFFSET_StgFunInfoExtraFwd_slow_apply]-#define OFFSET_StgFunInfoExtraFwd_fun_type 0-#define REP_StgFunInfoExtraFwd_fun_type b32-#define StgFunInfoExtraFwd_fun_type(__ptr__) REP_StgFunInfoExtraFwd_fun_type[__ptr__+OFFSET_StgFunInfoExtraFwd_fun_type]-#define OFFSET_StgFunInfoExtraFwd_arity 4-#define REP_StgFunInfoExtraFwd_arity b32-#define StgFunInfoExtraFwd_arity(__ptr__) REP_StgFunInfoExtraFwd_arity[__ptr__+OFFSET_StgFunInfoExtraFwd_arity]-#define OFFSET_StgFunInfoExtraFwd_bitmap 16-#define REP_StgFunInfoExtraFwd_bitmap b64-#define StgFunInfoExtraFwd_bitmap(__ptr__) REP_StgFunInfoExtraFwd_bitmap[__ptr__+OFFSET_StgFunInfoExtraFwd_bitmap]-#define SIZEOF_StgFunInfoExtraRev 24-#define OFFSET_StgFunInfoExtraRev_slow_apply_offset 0-#define REP_StgFunInfoExtraRev_slow_apply_offset b32-#define StgFunInfoExtraRev_slow_apply_offset(__ptr__) REP_StgFunInfoExtraRev_slow_apply_offset[__ptr__+OFFSET_StgFunInfoExtraRev_slow_apply_offset]-#define OFFSET_StgFunInfoExtraRev_fun_type 16-#define REP_StgFunInfoExtraRev_fun_type b32-#define StgFunInfoExtraRev_fun_type(__ptr__) REP_StgFunInfoExtraRev_fun_type[__ptr__+OFFSET_StgFunInfoExtraRev_fun_type]-#define OFFSET_StgFunInfoExtraRev_arity 20-#define REP_StgFunInfoExtraRev_arity b32-#define StgFunInfoExtraRev_arity(__ptr__) REP_StgFunInfoExtraRev_arity[__ptr__+OFFSET_StgFunInfoExtraRev_arity]-#define OFFSET_StgFunInfoExtraRev_bitmap 8-#define REP_StgFunInfoExtraRev_bitmap b64-#define StgFunInfoExtraRev_bitmap(__ptr__) REP_StgFunInfoExtraRev_bitmap[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap]-#define OFFSET_StgFunInfoExtraRev_bitmap_offset 8-#define REP_StgFunInfoExtraRev_bitmap_offset b32-#define StgFunInfoExtraRev_bitmap_offset(__ptr__) REP_StgFunInfoExtraRev_bitmap_offset[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap_offset]-#define OFFSET_StgLargeBitmap_size 0-#define REP_StgLargeBitmap_size b64-#define StgLargeBitmap_size(__ptr__) REP_StgLargeBitmap_size[__ptr__+OFFSET_StgLargeBitmap_size]-#define OFFSET_StgLargeBitmap_bitmap 8-#define SIZEOF_snEntry 24-#define OFFSET_snEntry_sn_obj 16-#define REP_snEntry_sn_obj b64-#define snEntry_sn_obj(__ptr__) REP_snEntry_sn_obj[__ptr__+OFFSET_snEntry_sn_obj]-#define OFFSET_snEntry_addr 0-#define REP_snEntry_addr b64-#define snEntry_addr(__ptr__) REP_snEntry_addr[__ptr__+OFFSET_snEntry_addr]-#define SIZEOF_spEntry 8-#define OFFSET_spEntry_addr 0-#define REP_spEntry_addr b64-#define spEntry_addr(__ptr__) REP_spEntry_addr[__ptr__+OFFSET_spEntry_addr]
− ghc-lib/generated/ghcautoconf.h 
@@ -1,596 +0,0 @@-#ifndef __GHCAUTOCONF_H__-#define __GHCAUTOCONF_H__-/* mk/config.h.  Generated from config.h.in by configure.  */-/* mk/config.h.in.  Generated from configure.ac by autoheader.  */--/* Define if building universal (internal helper macro) */-/* #undef AC_APPLE_UNIVERSAL_BUILD */--/* The alignment of a `char'. */-#define ALIGNMENT_CHAR 1--/* The alignment of a `double'. */-#define ALIGNMENT_DOUBLE 8--/* The alignment of a `float'. */-#define ALIGNMENT_FLOAT 4--/* The alignment of a `int'. */-#define ALIGNMENT_INT 4--/* The alignment of a `int16_t'. */-#define ALIGNMENT_INT16_T 2--/* The alignment of a `int32_t'. */-#define ALIGNMENT_INT32_T 4--/* The alignment of a `int64_t'. */-#define ALIGNMENT_INT64_T 8--/* The alignment of a `int8_t'. */-#define ALIGNMENT_INT8_T 1--/* The alignment of a `long'. */-#define ALIGNMENT_LONG 8--/* The alignment of a `long long'. */-#define ALIGNMENT_LONG_LONG 8--/* The alignment of a `short'. */-#define ALIGNMENT_SHORT 2--/* The alignment of a `uint16_t'. */-#define ALIGNMENT_UINT16_T 2--/* The alignment of a `uint32_t'. */-#define ALIGNMENT_UINT32_T 4--/* The alignment of a `uint64_t'. */-#define ALIGNMENT_UINT64_T 8--/* The alignment of a `uint8_t'. */-#define ALIGNMENT_UINT8_T 1--/* The alignment of a `unsigned char'. */-#define ALIGNMENT_UNSIGNED_CHAR 1--/* The alignment of a `unsigned int'. */-#define ALIGNMENT_UNSIGNED_INT 4--/* The alignment of a `unsigned long'. */-#define ALIGNMENT_UNSIGNED_LONG 8--/* The alignment of a `unsigned long long'. */-#define ALIGNMENT_UNSIGNED_LONG_LONG 8--/* The alignment of a `unsigned short'. */-#define ALIGNMENT_UNSIGNED_SHORT 2--/* The alignment of a `void *'. */-#define ALIGNMENT_VOID_P 8--/* Define to 1 if __thread is supported */-#define CC_SUPPORTS_TLS 1--/* Define to 1 if using 'alloca.c'. */-/* #undef C_ALLOCA */--/* Define to 1 if your processor stores words of floats with the most-   significant byte first */-/* #undef FLOAT_WORDS_BIGENDIAN */--/* Has visibility hidden */-#define HAS_VISIBILITY_HIDDEN 1--/* Define to 1 if you have 'alloca', as a function or macro. */-#define HAVE_ALLOCA 1--/* Define to 1 if <alloca.h> works. */-#define HAVE_ALLOCA_H 1--/* Define to 1 if you have the <bfd.h> header file. */-/* #undef HAVE_BFD_H */--/* Does GCC support __atomic primitives? */-#define HAVE_C11_ATOMICS $CONF_GCC_SUPPORTS__ATOMICS--/* Define to 1 if you have the `clock_gettime' function. */-#define HAVE_CLOCK_GETTIME 1--/* Define to 1 if you have the `ctime_r' function. */-#define HAVE_CTIME_R 1--/* Define to 1 if you have the <ctype.h> header file. */-#define HAVE_CTYPE_H 1--/* Define to 1 if you have the declaration of `ctime_r', and to 0 if you-   don't. */-#define HAVE_DECL_CTIME_R 1--/* Define to 1 if you have the declaration of `MADV_DONTNEED', and to 0 if you-   don't. */-/* #undef HAVE_DECL_MADV_DONTNEED */--/* Define to 1 if you have the declaration of `MADV_FREE', and to 0 if you-   don't. */-/* #undef HAVE_DECL_MADV_FREE */--/* Define to 1 if you have the declaration of `MAP_NORESERVE', and to 0 if you-   don't. */-/* #undef HAVE_DECL_MAP_NORESERVE */--/* Define to 1 if you have the <dirent.h> header file. */-#define HAVE_DIRENT_H 1--/* Define to 1 if you have the <dlfcn.h> header file. */-#define HAVE_DLFCN_H 1--/* Define to 1 if you have the <errno.h> header file. */-#define HAVE_ERRNO_H 1--/* Define to 1 if you have the `eventfd' function. */-/* #undef HAVE_EVENTFD */--/* Define to 1 if you have the <fcntl.h> header file. */-#define HAVE_FCNTL_H 1--/* Define to 1 if you have the <ffi.h> header file. */-/* #undef HAVE_FFI_H */--/* Define to 1 if you have the `fork' function. */-#define HAVE_FORK 1--/* Define to 1 if you have the `getclock' function. */-/* #undef HAVE_GETCLOCK */--/* Define to 1 if you have the `GetModuleFileName' function. */-/* #undef HAVE_GETMODULEFILENAME */--/* Define to 1 if you have the `getrusage' function. */-#define HAVE_GETRUSAGE 1--/* Define to 1 if you have the `gettimeofday' function. */-#define HAVE_GETTIMEOFDAY 1--/* Define to 1 if you have the <grp.h> header file. */-#define HAVE_GRP_H 1--/* Define to 1 if you have the <inttypes.h> header file. */-#define HAVE_INTTYPES_H 1--/* Define to 1 if you have the `bfd' library (-lbfd). */-/* #undef HAVE_LIBBFD */--/* Define to 1 if you have the `dl' library (-ldl). */-#define HAVE_LIBDL 1--/* Define to 1 if you have libffi. */-/* #undef HAVE_LIBFFI */--/* Define to 1 if you have the `iberty' library (-liberty). */-/* #undef HAVE_LIBIBERTY */--/* Define to 1 if you need to link with libm */-#define HAVE_LIBM 1--/* Define to 1 if you have libnuma */-#define HAVE_LIBNUMA 0--/* Define to 1 if you have the `pthread' library (-lpthread). */-#define HAVE_LIBPTHREAD 1--/* Define to 1 if you have the `rt' library (-lrt). */-/* #undef HAVE_LIBRT */--/* Define to 1 if you have the <limits.h> header file. */-#define HAVE_LIMITS_H 1--/* Define to 1 if you have the <locale.h> header file. */-#define HAVE_LOCALE_H 1--/* Define to 1 if the system has the type `long long'. */-#define HAVE_LONG_LONG 1--/* Define to 1 if you have the mingwex library. */-/* #undef HAVE_MINGWEX */--/* Define to 1 if you have the <minix/config.h> header file. */-/* #undef HAVE_MINIX_CONFIG_H */--/* Define to 1 if you have the <nlist.h> header file. */-#define HAVE_NLIST_H 1--/* Define to 1 if you have the <numaif.h> header file. */-/* #undef HAVE_NUMAIF_H */--/* Define to 1 if you have the <numa.h> header file. */-/* #undef HAVE_NUMA_H */--/* Define to 1 if we have printf$LDBLStub (Apple Mac OS >= 10.4, PPC). */-#define HAVE_PRINTF_LDBLSTUB 0--/* Define to 1 if you have the <pthread.h> header file. */-#define HAVE_PTHREAD_H 1--/* Define to 1 if you have the glibc version of pthread_setname_np */-/* #undef HAVE_PTHREAD_SETNAME_NP */--/* Define to 1 if you have the <pwd.h> header file. */-#define HAVE_PWD_H 1--/* Define to 1 if you have the <sched.h> header file. */-#define HAVE_SCHED_H 1--/* Define to 1 if you have the `sched_setaffinity' function. */-/* #undef HAVE_SCHED_SETAFFINITY */--/* Define to 1 if you have the `setitimer' function. */-#define HAVE_SETITIMER 1--/* Define to 1 if you have the `setlocale' function. */-#define HAVE_SETLOCALE 1--/* Define to 1 if you have the `siginterrupt' function. */-#define HAVE_SIGINTERRUPT 1--/* Define to 1 if you have the <signal.h> header file. */-#define HAVE_SIGNAL_H 1--/* Define to 1 if you have the <stdint.h> header file. */-#define HAVE_STDINT_H 1--/* Define to 1 if you have the <stdio.h> header file. */-#define HAVE_STDIO_H 1--/* Define to 1 if you have the <stdlib.h> header file. */-#define HAVE_STDLIB_H 1--/* Define to 1 if you have the <strings.h> header file. */-#define HAVE_STRINGS_H 1--/* Define to 1 if you have the <string.h> header file. */-#define HAVE_STRING_H 1--/* Define to 1 if Apple-style dead-stripping is supported. */-#define HAVE_SUBSECTIONS_VIA_SYMBOLS 1--/* Define to 1 if you have the `sysconf' function. */-#define HAVE_SYSCONF 1--/* Define to 1 if you have the <sys/cpuset.h> header file. */-/* #undef HAVE_SYS_CPUSET_H */--/* Define to 1 if you have the <sys/eventfd.h> header file. */-/* #undef HAVE_SYS_EVENTFD_H */--/* Define to 1 if you have the <sys/mman.h> header file. */-#define HAVE_SYS_MMAN_H 1--/* Define to 1 if you have the <sys/param.h> header file. */-#define HAVE_SYS_PARAM_H 1--/* Define to 1 if you have the <sys/resource.h> header file. */-#define HAVE_SYS_RESOURCE_H 1--/* Define to 1 if you have the <sys/select.h> header file. */-#define HAVE_SYS_SELECT_H 1--/* Define to 1 if you have the <sys/stat.h> header file. */-#define HAVE_SYS_STAT_H 1--/* Define to 1 if you have the <sys/timeb.h> header file. */-#define HAVE_SYS_TIMEB_H 1--/* Define to 1 if you have the <sys/timerfd.h> header file. */-/* #undef HAVE_SYS_TIMERFD_H */--/* Define to 1 if you have the <sys/timers.h> header file. */-/* #undef HAVE_SYS_TIMERS_H */--/* Define to 1 if you have the <sys/times.h> header file. */-#define HAVE_SYS_TIMES_H 1--/* Define to 1 if you have the <sys/time.h> header file. */-#define HAVE_SYS_TIME_H 1--/* Define to 1 if you have the <sys/types.h> header file. */-#define HAVE_SYS_TYPES_H 1--/* Define to 1 if you have the <sys/utsname.h> header file. */-#define HAVE_SYS_UTSNAME_H 1--/* Define to 1 if you have the <sys/wait.h> header file. */-#define HAVE_SYS_WAIT_H 1--/* Define to 1 if you have the <termios.h> header file. */-#define HAVE_TERMIOS_H 1--/* Define to 1 if you have the `timer_settime' function. */-/* #undef HAVE_TIMER_SETTIME */--/* Define to 1 if you have the `times' function. */-#define HAVE_TIMES 1--/* Define to 1 if you have the <time.h> header file. */-#define HAVE_TIME_H 1--/* Define to 1 if you have the <unistd.h> header file. */-#define HAVE_UNISTD_H 1--/* Define to 1 if you have the <utime.h> header file. */-#define HAVE_UTIME_H 1--/* Define to 1 if you have the `vfork' function. */-#define HAVE_VFORK 1--/* Define to 1 if you have the <vfork.h> header file. */-/* #undef HAVE_VFORK_H */--/* Define to 1 if you have the <wchar.h> header file. */-#define HAVE_WCHAR_H 1--/* Define to 1 if you have the <windows.h> header file. */-/* #undef HAVE_WINDOWS_H */--/* Define to 1 if you have the `WinExec' function. */-/* #undef HAVE_WINEXEC */--/* Define to 1 if you have the <winsock.h> header file. */-/* #undef HAVE_WINSOCK_H */--/* Define to 1 if `fork' works. */-#define HAVE_WORKING_FORK 1--/* Define to 1 if `vfork' works. */-#define HAVE_WORKING_VFORK 1--/* Define to 1 if C symbols have a leading underscore added by the compiler.-   */-#define LEADING_UNDERSCORE 1--/* Define 1 if we need to link code using pthreads with -lpthread */-#define NEED_PTHREAD_LIB 0--/* Define to the address where bug reports for this package should be sent. */-/* #undef PACKAGE_BUGREPORT */--/* Define to the full name of this package. */-/* #undef PACKAGE_NAME */--/* Define to the full name and version of this package. */-/* #undef PACKAGE_STRING */--/* Define to the one symbol short name of this package. */-/* #undef PACKAGE_TARNAME */--/* Define to the home page for this package. */-/* #undef PACKAGE_URL */--/* Define to the version of this package. */-/* #undef PACKAGE_VERSION */--/* Use mmap in the runtime linker */-#define RTS_LINKER_USE_MMAP 1--/* The size of `char', as computed by sizeof. */-#define SIZEOF_CHAR 1--/* The size of `double', as computed by sizeof. */-#define SIZEOF_DOUBLE 8--/* The size of `float', as computed by sizeof. */-#define SIZEOF_FLOAT 4--/* The size of `int', as computed by sizeof. */-#define SIZEOF_INT 4--/* The size of `int16_t', as computed by sizeof. */-#define SIZEOF_INT16_T 2--/* The size of `int32_t', as computed by sizeof. */-#define SIZEOF_INT32_T 4--/* The size of `int64_t', as computed by sizeof. */-#define SIZEOF_INT64_T 8--/* The size of `int8_t', as computed by sizeof. */-#define SIZEOF_INT8_T 1--/* The size of `long', as computed by sizeof. */-#define SIZEOF_LONG 8--/* The size of `long long', as computed by sizeof. */-#define SIZEOF_LONG_LONG 8--/* The size of `short', as computed by sizeof. */-#define SIZEOF_SHORT 2--/* The size of `uint16_t', as computed by sizeof. */-#define SIZEOF_UINT16_T 2--/* The size of `uint32_t', as computed by sizeof. */-#define SIZEOF_UINT32_T 4--/* The size of `uint64_t', as computed by sizeof. */-#define SIZEOF_UINT64_T 8--/* The size of `uint8_t', as computed by sizeof. */-#define SIZEOF_UINT8_T 1--/* The size of `unsigned char', as computed by sizeof. */-#define SIZEOF_UNSIGNED_CHAR 1--/* The size of `unsigned int', as computed by sizeof. */-#define SIZEOF_UNSIGNED_INT 4--/* The size of `unsigned long', as computed by sizeof. */-#define SIZEOF_UNSIGNED_LONG 8--/* The size of `unsigned long long', as computed by sizeof. */-#define SIZEOF_UNSIGNED_LONG_LONG 8--/* The size of `unsigned short', as computed by sizeof. */-#define SIZEOF_UNSIGNED_SHORT 2--/* The size of `void *', as computed by sizeof. */-#define SIZEOF_VOID_P 8--/* If using the C implementation of alloca, define if you know the-   direction of stack growth for your system; otherwise it will be-   automatically deduced at runtime.-	STACK_DIRECTION > 0 => grows toward higher addresses-	STACK_DIRECTION < 0 => grows toward lower addresses-	STACK_DIRECTION = 0 => direction of growth unknown */-/* #undef STACK_DIRECTION */--/* Define to 1 if all of the C90 standard headers exist (not just the ones-   required in a freestanding environment). This macro is provided for-   backward compatibility; new code need not use it. */-#define STDC_HEADERS 1--/* Define to 1 if you can safely include both <sys/time.h> and <time.h>. This-   macro is obsolete. */-#define TIME_WITH_SYS_TIME 1--/* Enable single heap address space support */-#define USE_LARGE_ADDRESS_SPACE 1--/* Set to 1 to use libdw */-#define USE_LIBDW 0--/* Enable extensions on AIX 3, Interix.  */-#ifndef _ALL_SOURCE-# define _ALL_SOURCE 1-#endif-/* Enable general extensions on macOS.  */-#ifndef _DARWIN_C_SOURCE-# define _DARWIN_C_SOURCE 1-#endif-/* Enable general extensions on Solaris.  */-#ifndef __EXTENSIONS__-# define __EXTENSIONS__ 1-#endif-/* Enable GNU extensions on systems that have them.  */-#ifndef _GNU_SOURCE-# define _GNU_SOURCE 1-#endif-/* Enable X/Open compliant socket functions that do not require linking-   with -lxnet on HP-UX 11.11.  */-#ifndef _HPUX_ALT_XOPEN_SOCKET_API-# define _HPUX_ALT_XOPEN_SOCKET_API 1-#endif-/* Identify the host operating system as Minix.-   This macro does not affect the system headers' behavior.-   A future release of Autoconf may stop defining this macro.  */-#ifndef _MINIX-/* # undef _MINIX */-#endif-/* Enable general extensions on NetBSD.-   Enable NetBSD compatibility extensions on Minix.  */-#ifndef _NETBSD_SOURCE-# define _NETBSD_SOURCE 1-#endif-/* Enable OpenBSD compatibility extensions on NetBSD.-   Oddly enough, this does nothing on OpenBSD.  */-#ifndef _OPENBSD_SOURCE-# define _OPENBSD_SOURCE 1-#endif-/* Define to 1 if needed for POSIX-compatible behavior.  */-#ifndef _POSIX_SOURCE-/* # undef _POSIX_SOURCE */-#endif-/* Define to 2 if needed for POSIX-compatible behavior.  */-#ifndef _POSIX_1_SOURCE-/* # undef _POSIX_1_SOURCE */-#endif-/* Enable POSIX-compatible threading on Solaris.  */-#ifndef _POSIX_PTHREAD_SEMANTICS-# define _POSIX_PTHREAD_SEMANTICS 1-#endif-/* Enable extensions specified by ISO/IEC TS 18661-5:2014.  */-#ifndef __STDC_WANT_IEC_60559_ATTRIBS_EXT__-# define __STDC_WANT_IEC_60559_ATTRIBS_EXT__ 1-#endif-/* Enable extensions specified by ISO/IEC TS 18661-1:2014.  */-#ifndef __STDC_WANT_IEC_60559_BFP_EXT__-# define __STDC_WANT_IEC_60559_BFP_EXT__ 1-#endif-/* Enable extensions specified by ISO/IEC TS 18661-2:2015.  */-#ifndef __STDC_WANT_IEC_60559_DFP_EXT__-# define __STDC_WANT_IEC_60559_DFP_EXT__ 1-#endif-/* Enable extensions specified by ISO/IEC TS 18661-4:2015.  */-#ifndef __STDC_WANT_IEC_60559_FUNCS_EXT__-# define __STDC_WANT_IEC_60559_FUNCS_EXT__ 1-#endif-/* Enable extensions specified by ISO/IEC TS 18661-3:2015.  */-#ifndef __STDC_WANT_IEC_60559_TYPES_EXT__-# define __STDC_WANT_IEC_60559_TYPES_EXT__ 1-#endif-/* Enable extensions specified by ISO/IEC TR 24731-2:2010.  */-#ifndef __STDC_WANT_LIB_EXT2__-# define __STDC_WANT_LIB_EXT2__ 1-#endif-/* Enable extensions specified by ISO/IEC 24747:2009.  */-#ifndef __STDC_WANT_MATH_SPEC_FUNCS__-# define __STDC_WANT_MATH_SPEC_FUNCS__ 1-#endif-/* Enable extensions on HP NonStop.  */-#ifndef _TANDEM_SOURCE-# define _TANDEM_SOURCE 1-#endif-/* Enable X/Open extensions.  Define to 500 only if necessary-   to make mbstate_t available.  */-#ifndef _XOPEN_SOURCE-/* # undef _XOPEN_SOURCE */-#endif---/* Define to 1 if we can use timer_create(CLOCK_REALTIME,...) */-/* #undef USE_TIMER_CREATE */--/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most-   significant byte first (like Motorola and SPARC, unlike Intel). */-#if defined AC_APPLE_UNIVERSAL_BUILD-# if defined __BIG_ENDIAN__-#  define WORDS_BIGENDIAN 1-# endif-#else-# ifndef WORDS_BIGENDIAN-/* #  undef WORDS_BIGENDIAN */-# endif-#endif--/* Number of bits in a file offset, on hosts where this is settable. */-/* #undef _FILE_OFFSET_BITS */--/* Define for large files, on AIX-style hosts. */-/* #undef _LARGE_FILES */--/* ARM pre v6 */-/* #undef arm_HOST_ARCH_PRE_ARMv6 */--/* ARM pre v7 */-/* #undef arm_HOST_ARCH_PRE_ARMv7 */--/* Define to empty if `const' does not conform to ANSI C. */-/* #undef const */--/* Define as a signed integer type capable of holding a process identifier. */-/* #undef pid_t */--/* The supported LLVM version number */-#define sUPPORTED_LLVM_VERSION (7)--/* Define to `unsigned int' if <sys/types.h> does not define. */-/* #undef size_t */--/* Define as `fork' if `vfork' does not work. */-/* #undef vfork */--#define TABLES_NEXT_TO_CODE 1--#define llvm_CC_FLAVOR 1--#define clang_CC_FLAVOR 1-#endif /* __GHCAUTOCONF_H__ */
− ghc-lib/generated/ghcplatform.h 
@@ -1,34 +0,0 @@-#ifndef __GHCPLATFORM_H__-#define __GHCPLATFORM_H__--#define BuildPlatform_TYPE  x86_64_apple_darwin-#define HostPlatform_TYPE   x86_64_apple_darwin--#define x86_64_apple_darwin_BUILD 1-#define x86_64_apple_darwin_HOST 1--#define x86_64_BUILD_ARCH 1-#define x86_64_HOST_ARCH 1-#define BUILD_ARCH "x86_64"-#define HOST_ARCH "x86_64"--#define darwin_BUILD_OS 1-#define darwin_HOST_OS 1-#define BUILD_OS "darwin"-#define HOST_OS "darwin"--#define apple_BUILD_VENDOR 1-#define apple_HOST_VENDOR 1-#define BUILD_VENDOR "apple"-#define HOST_VENDOR "apple"--/* These TARGET macros are for backwards compatibility... DO NOT USE! */-#define TargetPlatform_TYPE x86_64_apple_darwin-#define x86_64_apple_darwin_TARGET 1-#define x86_64_TARGET_ARCH 1-#define TARGET_ARCH "x86_64"-#define darwin_TARGET_OS 1-#define TARGET_OS "darwin"-#define apple_TARGET_VENDOR 1--#endif /* __GHCPLATFORM_H__ */
− ghc-lib/stage0/compiler/build/Fingerprint.hs 
@@ -1,48 +0,0 @@-{-# LINE 1 "compiler/utils/Fingerprint.hsc" #-}-{-# LANGUAGE CPP #-}---- ----------------------------------------------------------------------------------  (c) The University of Glasgow 2006------ Fingerprints for recompilation checking and ABI versioning.------ http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance------ ------------------------------------------------------------------------------module Fingerprint (-        readHexFingerprint,-        fingerprintByteString,-        -- * Re-exported from GHC.Fingerprint-        Fingerprint(..), fingerprint0,-        fingerprintFingerprints,-        fingerprintData,-        fingerprintString,-        getFileHash-   ) where---#include "GhclibHsVersions.h"--import GhcPrelude--import Foreign-import GHC.IO-import Numeric          ( readHex )--import qualified Data.ByteString as BS-import qualified Data.ByteString.Unsafe as BS--import GHC.Fingerprint---- useful for parsing the output of 'md5sum', should we want to do that.-readHexFingerprint :: String -> Fingerprint-readHexFingerprint s = Fingerprint w1 w2- where (s1,s2) = splitAt 16 s-       [(w1,"")] = readHex s1-       [(w2,"")] = readHex (take 16 s2)--fingerprintByteString :: BS.ByteString -> Fingerprint-fingerprintByteString bs = unsafeDupablePerformIO $-  BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> fingerprintData (castPtr ptr) len
− ghc-lib/stage0/compiler/build/ghc_boot_platform.h 
@@ -1,34 +0,0 @@-#ifndef __PLATFORM_H__-#define __PLATFORM_H__--#define BuildPlatform_NAME  "x86_64-apple-darwin"-#define HostPlatform_NAME   "x86_64-apple-darwin"-#define TargetPlatform_NAME "x86_64-apple-darwin"--#define x86_64_apple_darwin_BUILD 1-#define x86_64_apple_darwin_HOST 1-#define x86_64_apple_darwin_TARGET 1--#define x86_64_BUILD_ARCH 1-#define x86_64_HOST_ARCH 1-#define x86_64_TARGET_ARCH 1-#define BUILD_ARCH "x86_64"-#define HOST_ARCH "x86_64"-#define TARGET_ARCH "x86_64"-#define LLVM_TARGET "x86_64-apple-darwin"--#define darwin_BUILD_OS 1-#define darwin_HOST_OS 1-#define darwin_TARGET_OS 1-#define BUILD_OS "darwin"-#define HOST_OS "darwin"-#define TARGET_OS "darwin"--#define apple_BUILD_VENDOR 1-#define apple_HOST_VENDOR 1-#define apple_TARGET_VENDOR  1-#define BUILD_VENDOR "apple"-#define HOST_VENDOR "apple"-#define TARGET_VENDOR "apple"--#endif /* __PLATFORM_H__ */
ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl view
@@ -19,10 +19,12 @@ primOpCanFail WordQuotRem2Op = True primOpCanFail DoubleDivOp = True primOpCanFail DoubleLogOp = True+primOpCanFail DoubleLog1POp = True primOpCanFail DoubleAsinOp = True primOpCanFail DoubleAcosOp = True primOpCanFail FloatDivOp = True primOpCanFail FloatLogOp = True+primOpCanFail FloatLog1POp = True primOpCanFail FloatAsinOp = True primOpCanFail FloatAcosOp = True primOpCanFail ReadArrayOp = True
ghc-lib/stage0/compiler/build/primop-code-size.hs-incl view
@@ -8,7 +8,9 @@ primOpCodeSize WordAdd2Op = 2 primOpCodeSize Word2IntOp = 0 primOpCodeSize DoubleExpOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleExpM1Op =  primOpCodeSizeForeignCall  primOpCodeSize DoubleLogOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleLog1POp =  primOpCodeSizeForeignCall  primOpCodeSize DoubleSqrtOp =  primOpCodeSizeForeignCall  primOpCodeSize DoubleSinOp =  primOpCodeSizeForeignCall  primOpCodeSize DoubleCosOp =  primOpCodeSizeForeignCall @@ -24,7 +26,9 @@ primOpCodeSize DoubleAtanhOp =  primOpCodeSizeForeignCall  primOpCodeSize DoublePowerOp =  primOpCodeSizeForeignCall  primOpCodeSize FloatExpOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatExpM1Op =  primOpCodeSizeForeignCall  primOpCodeSize FloatLogOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatLog1POp =  primOpCodeSizeForeignCall  primOpCodeSize FloatSqrtOp =  primOpCodeSizeForeignCall  primOpCodeSize FloatSinOp =  primOpCodeSizeForeignCall  primOpCodeSize FloatCosOp =  primOpCodeSizeForeignCall
ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl view
@@ -148,6 +148,11 @@    | BSwap32Op    | BSwap64Op    | BSwapOp+   | BRev8Op+   | BRev16Op+   | BRev32Op+   | BRev64Op+   | BRevOp    | Narrow8IntOp    | Narrow16IntOp    | Narrow32IntOp@@ -169,7 +174,9 @@    | Double2IntOp    | Double2FloatOp    | DoubleExpOp+   | DoubleExpM1Op    | DoubleLogOp+   | DoubleLog1POp    | DoubleSqrtOp    | DoubleSinOp    | DoubleCosOp@@ -200,7 +207,9 @@    | FloatFabsOp    | Float2IntOp    | FloatExpOp+   | FloatExpM1Op    | FloatLogOp+   | FloatLog1POp    | FloatSqrtOp    | FloatSinOp    | FloatCosOp@@ -235,10 +244,12 @@    | CasArrayOp    | NewSmallArrayOp    | SameSmallMutableArrayOp+   | ShrinkSmallMutableArrayOp_Char    | ReadSmallArrayOp    | WriteSmallArrayOp    | SizeofSmallArrayOp    | SizeofSmallMutableArrayOp+   | GetSizeofSmallMutableArrayOp    | IndexSmallArrayOp    | UnsafeFreezeSmallArrayOp    | UnsafeThawSmallArrayOp@@ -524,6 +535,7 @@    | MkApUpd0_Op    | NewBCOOp    | UnpackClosureOp+   | ClosureSizeOp    | GetApStackValOp    | GetCCSOfOp    | GetCurrentCCSOp@@ -531,7 +543,6 @@    | TraceEventOp    | TraceEventBinaryOp    | TraceMarkerOp-   | GetThreadAllocationCounter    | SetThreadAllocationCounter    | VecBroadcastOp PrimOpVecCat Length Width    | VecPackOp PrimOpVecCat Length Width
ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl view
@@ -11,6 +11,7 @@ primOpHasSideEffects ThawArrayOp = True primOpHasSideEffects CasArrayOp = True primOpHasSideEffects NewSmallArrayOp = True+primOpHasSideEffects ShrinkSmallMutableArrayOp_Char = True primOpHasSideEffects ReadSmallArrayOp = True primOpHasSideEffects WriteSmallArrayOp = True primOpHasSideEffects UnsafeFreezeSmallArrayOp = True@@ -213,7 +214,6 @@ primOpHasSideEffects TraceEventOp = True primOpHasSideEffects TraceEventBinaryOp = True primOpHasSideEffects TraceMarkerOp = True-primOpHasSideEffects GetThreadAllocationCounter = True primOpHasSideEffects SetThreadAllocationCounter = True primOpHasSideEffects (VecReadByteArrayOp _ _ _) = True primOpHasSideEffects (VecWriteByteArrayOp _ _ _) = True
ghc-lib/stage0/compiler/build/primop-list.hs-incl view
@@ -147,6 +147,11 @@    , BSwap32Op    , BSwap64Op    , BSwapOp+   , BRev8Op+   , BRev16Op+   , BRev32Op+   , BRev64Op+   , BRevOp    , Narrow8IntOp    , Narrow16IntOp    , Narrow32IntOp@@ -168,7 +173,9 @@    , Double2IntOp    , Double2FloatOp    , DoubleExpOp+   , DoubleExpM1Op    , DoubleLogOp+   , DoubleLog1POp    , DoubleSqrtOp    , DoubleSinOp    , DoubleCosOp@@ -199,7 +206,9 @@    , FloatFabsOp    , Float2IntOp    , FloatExpOp+   , FloatExpM1Op    , FloatLogOp+   , FloatLog1POp    , FloatSqrtOp    , FloatSinOp    , FloatCosOp@@ -234,10 +243,12 @@    , CasArrayOp    , NewSmallArrayOp    , SameSmallMutableArrayOp+   , ShrinkSmallMutableArrayOp_Char    , ReadSmallArrayOp    , WriteSmallArrayOp    , SizeofSmallArrayOp    , SizeofSmallMutableArrayOp+   , GetSizeofSmallMutableArrayOp    , IndexSmallArrayOp    , UnsafeFreezeSmallArrayOp    , UnsafeThawSmallArrayOp@@ -523,6 +534,7 @@    , MkApUpd0_Op    , NewBCOOp    , UnpackClosureOp+   , ClosureSizeOp    , GetApStackValOp    , GetCCSOfOp    , GetCurrentCCSOp@@ -530,7 +542,6 @@    , TraceEventOp    , TraceEventBinaryOp    , TraceMarkerOp-   , GetThreadAllocationCounter    , SetThreadAllocationCounter    , (VecBroadcastOp IntVec 16 W8)    , (VecBroadcastOp IntVec 8 W16)
ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl view
@@ -11,6 +11,7 @@ primOpOutOfLine ThawArrayOp = True primOpOutOfLine CasArrayOp = True primOpOutOfLine NewSmallArrayOp = True+primOpOutOfLine ShrinkSmallMutableArrayOp_Char = True primOpOutOfLine UnsafeThawSmallArrayOp = True primOpOutOfLine CopySmallArrayOp = True primOpOutOfLine CopySmallMutableArrayOp = True@@ -91,11 +92,11 @@ primOpOutOfLine MkApUpd0_Op = True primOpOutOfLine NewBCOOp = True primOpOutOfLine UnpackClosureOp = True+primOpOutOfLine ClosureSizeOp = True primOpOutOfLine GetApStackValOp = True primOpOutOfLine ClearCCSOp = True primOpOutOfLine TraceEventOp = True primOpOutOfLine TraceEventBinaryOp = True primOpOutOfLine TraceMarkerOp = True-primOpOutOfLine GetThreadAllocationCounter = True primOpOutOfLine SetThreadAllocationCounter = True primOpOutOfLine _ = False
ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl view
@@ -147,6 +147,11 @@ primOpInfo BSwap32Op = mkMonadic (fsLit "byteSwap32#") wordPrimTy primOpInfo BSwap64Op = mkMonadic (fsLit "byteSwap64#") wordPrimTy primOpInfo BSwapOp = mkMonadic (fsLit "byteSwap#") wordPrimTy+primOpInfo BRev8Op = mkMonadic (fsLit "bitReverse8#") wordPrimTy+primOpInfo BRev16Op = mkMonadic (fsLit "bitReverse16#") wordPrimTy+primOpInfo BRev32Op = mkMonadic (fsLit "bitReverse32#") wordPrimTy+primOpInfo BRev64Op = mkMonadic (fsLit "bitReverse64#") wordPrimTy+primOpInfo BRevOp = mkMonadic (fsLit "bitReverse#") wordPrimTy primOpInfo Narrow8IntOp = mkMonadic (fsLit "narrow8Int#") intPrimTy primOpInfo Narrow16IntOp = mkMonadic (fsLit "narrow16Int#") intPrimTy primOpInfo Narrow32IntOp = mkMonadic (fsLit "narrow32Int#") intPrimTy@@ -168,7 +173,9 @@ primOpInfo Double2IntOp = mkGenPrimOp (fsLit "double2Int#")  [] [doublePrimTy] (intPrimTy) primOpInfo Double2FloatOp = mkGenPrimOp (fsLit "double2Float#")  [] [doublePrimTy] (floatPrimTy) primOpInfo DoubleExpOp = mkMonadic (fsLit "expDouble#") doublePrimTy+primOpInfo DoubleExpM1Op = mkMonadic (fsLit "expm1Double#") doublePrimTy primOpInfo DoubleLogOp = mkMonadic (fsLit "logDouble#") doublePrimTy+primOpInfo DoubleLog1POp = mkMonadic (fsLit "log1pDouble#") doublePrimTy primOpInfo DoubleSqrtOp = mkMonadic (fsLit "sqrtDouble#") doublePrimTy primOpInfo DoubleSinOp = mkMonadic (fsLit "sinDouble#") doublePrimTy primOpInfo DoubleCosOp = mkMonadic (fsLit "cosDouble#") doublePrimTy@@ -199,7 +206,9 @@ primOpInfo FloatFabsOp = mkMonadic (fsLit "fabsFloat#") floatPrimTy primOpInfo Float2IntOp = mkGenPrimOp (fsLit "float2Int#")  [] [floatPrimTy] (intPrimTy) primOpInfo FloatExpOp = mkMonadic (fsLit "expFloat#") floatPrimTy+primOpInfo FloatExpM1Op = mkMonadic (fsLit "expm1Float#") floatPrimTy primOpInfo FloatLogOp = mkMonadic (fsLit "logFloat#") floatPrimTy+primOpInfo FloatLog1POp = mkMonadic (fsLit "log1pFloat#") floatPrimTy primOpInfo FloatSqrtOp = mkMonadic (fsLit "sqrtFloat#") floatPrimTy primOpInfo FloatSinOp = mkMonadic (fsLit "sinFloat#") floatPrimTy primOpInfo FloatCosOp = mkMonadic (fsLit "cosFloat#") floatPrimTy@@ -234,10 +243,12 @@ primOpInfo CasArrayOp = mkGenPrimOp (fsLit "casArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) primOpInfo NewSmallArrayOp = mkGenPrimOp (fsLit "newSmallArray#")  [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) primOpInfo SameSmallMutableArrayOp = mkGenPrimOp (fsLit "sameSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo ShrinkSmallMutableArrayOp_Char = mkGenPrimOp (fsLit "shrinkSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo ReadSmallArrayOp = mkGenPrimOp (fsLit "readSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) primOpInfo WriteSmallArrayOp = mkGenPrimOp (fsLit "writeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo SizeofSmallArrayOp = mkGenPrimOp (fsLit "sizeofSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy] (intPrimTy) primOpInfo SizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "sizeofSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo GetSizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "getSizeofSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo IndexSmallArrayOp = mkGenPrimOp (fsLit "indexSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy])) primOpInfo UnsafeFreezeSmallArrayOp = mkGenPrimOp (fsLit "unsafeFreezeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy])) primOpInfo UnsafeThawSmallArrayOp = mkGenPrimOp (fsLit "unsafeThawSmallArray#")  [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))@@ -447,20 +458,20 @@ primOpInfo ReadMutVarOp = mkGenPrimOp (fsLit "readMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) primOpInfo WriteMutVarOp = mkGenPrimOp (fsLit "writeMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo SameMutVarOp = mkGenPrimOp (fsLit "sameMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkMutVarPrimTy deltaTy alphaTy] (intPrimTy)-primOpInfo AtomicModifyMutVar2Op = mkGenPrimOp (fsLit "atomicModifyMutVar2#")  [deltaTyVar, alphaTyVar, gammaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkFunTy (alphaTy) (gammaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, gammaTy]))-primOpInfo AtomicModifyMutVar_Op = mkGenPrimOp (fsLit "atomicModifyMutVar_#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkFunTy (alphaTy) (alphaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, alphaTy]))+primOpInfo AtomicModifyMutVar2Op = mkGenPrimOp (fsLit "atomicModifyMutVar2#")  [deltaTyVar, alphaTyVar, gammaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTy (alphaTy) (gammaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, gammaTy]))+primOpInfo AtomicModifyMutVar_Op = mkGenPrimOp (fsLit "atomicModifyMutVar_#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTy (alphaTy) (alphaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, alphaTy])) primOpInfo CasMutVarOp = mkGenPrimOp (fsLit "casMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))-primOpInfo CatchOp = mkGenPrimOp (fsLit "catch#")  [alphaTyVar, betaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkFunTy (betaTy) ((mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo CatchOp = mkGenPrimOp (fsLit "catch#")  [alphaTyVar, betaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTy (betaTy) ((mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) primOpInfo RaiseOp = mkGenPrimOp (fsLit "raise#")  [betaTyVar, runtimeRep1TyVar, openAlphaTyVar] [betaTy] (openAlphaTy) primOpInfo RaiseIOOp = mkGenPrimOp (fsLit "raiseIO#")  [alphaTyVar, betaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy]))-primOpInfo MaskAsyncExceptionsOp = mkGenPrimOp (fsLit "maskAsyncExceptions#")  [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo MaskUninterruptibleOp = mkGenPrimOp (fsLit "maskUninterruptible#")  [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo UnmaskAsyncExceptionsOp = mkGenPrimOp (fsLit "unmaskAsyncExceptions#")  [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo MaskAsyncExceptionsOp = mkGenPrimOp (fsLit "maskAsyncExceptions#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo MaskUninterruptibleOp = mkGenPrimOp (fsLit "maskUninterruptible#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo UnmaskAsyncExceptionsOp = mkGenPrimOp (fsLit "unmaskAsyncExceptions#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) primOpInfo MaskStatus = mkGenPrimOp (fsLit "getMaskingState#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))-primOpInfo AtomicallyOp = mkGenPrimOp (fsLit "atomically#")  [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo AtomicallyOp = mkGenPrimOp (fsLit "atomically#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) primOpInfo RetryOp = mkGenPrimOp (fsLit "retry#")  [alphaTyVar] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo CatchRetryOp = mkGenPrimOp (fsLit "catchRetry#")  [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo CatchSTMOp = mkGenPrimOp (fsLit "catchSTM#")  [alphaTyVar, betaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkFunTy (betaTy) ((mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo CatchRetryOp = mkGenPrimOp (fsLit "catchRetry#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo CatchSTMOp = mkGenPrimOp (fsLit "catchSTM#")  [alphaTyVar, betaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTy (betaTy) ((mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) primOpInfo NewTVarOp = mkGenPrimOp (fsLit "newTVar#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkTVarPrimTy deltaTy alphaTy])) primOpInfo ReadTVarOp = mkGenPrimOp (fsLit "readTVar#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) primOpInfo ReadTVarIOOp = mkGenPrimOp (fsLit "readTVarIO#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))@@ -487,11 +498,11 @@ primOpInfo IsCurrentThreadBoundOp = mkGenPrimOp (fsLit "isCurrentThreadBound#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) primOpInfo NoDuplicateOp = mkGenPrimOp (fsLit "noDuplicate#")  [deltaTyVar] [mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo ThreadStatusOp = mkGenPrimOp (fsLit "threadStatus#")  [] [threadIdPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, intPrimTy, intPrimTy]))-primOpInfo MkWeakOp = mkGenPrimOp (fsLit "mkWeak#")  [runtimeRep1TyVar, openAlphaTyVar, betaTyVar, gammaTyVar] [openAlphaTy, betaTy, (mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, gammaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy]))+primOpInfo MkWeakOp = mkGenPrimOp (fsLit "mkWeak#")  [runtimeRep1TyVar, openAlphaTyVar, betaTyVar, gammaTyVar] [openAlphaTy, betaTy, (mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, gammaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy])) primOpInfo MkWeakNoFinalizerOp = mkGenPrimOp (fsLit "mkWeakNoFinalizer#")  [runtimeRep1TyVar, openAlphaTyVar, betaTyVar] [openAlphaTy, betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy])) primOpInfo AddCFinalizerToWeakOp = mkGenPrimOp (fsLit "addCFinalizerToWeak#")  [betaTyVar] [addrPrimTy, addrPrimTy, intPrimTy, addrPrimTy, mkWeakPrimTy betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) primOpInfo DeRefWeakOp = mkGenPrimOp (fsLit "deRefWeak#")  [alphaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, alphaTy]))-primOpInfo FinalizeWeakOp = mkGenPrimOp (fsLit "finalizeWeak#")  [alphaTyVar, betaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, (mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])))]))+primOpInfo FinalizeWeakOp = mkGenPrimOp (fsLit "finalizeWeak#")  [alphaTyVar, betaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, (mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])))])) primOpInfo TouchOp = mkGenPrimOp (fsLit "touch#")  [runtimeRep1TyVar, openAlphaTyVar] [openAlphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo MakeStablePtrOp = mkGenPrimOp (fsLit "makeStablePtr#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStablePtrPrimTy alphaTy])) primOpInfo DeRefStablePtrOp = mkGenPrimOp (fsLit "deRefStablePtr#")  [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))@@ -523,14 +534,14 @@ primOpInfo MkApUpd0_Op = mkGenPrimOp (fsLit "mkApUpd0#")  [alphaTyVar] [bcoPrimTy] ((mkTupleTy Unboxed [alphaTy])) primOpInfo NewBCOOp = mkGenPrimOp (fsLit "newBCO#")  [alphaTyVar, deltaTyVar] [byteArrayPrimTy, byteArrayPrimTy, mkArrayPrimTy alphaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, bcoPrimTy])) primOpInfo UnpackClosureOp = mkGenPrimOp (fsLit "unpackClosure#")  [alphaTyVar, betaTyVar] [alphaTy] ((mkTupleTy Unboxed [addrPrimTy, byteArrayPrimTy, mkArrayPrimTy betaTy]))+primOpInfo ClosureSizeOp = mkGenPrimOp (fsLit "closureSize#")  [alphaTyVar] [alphaTy] (intPrimTy) primOpInfo GetApStackValOp = mkGenPrimOp (fsLit "getApStackVal#")  [alphaTyVar, betaTyVar] [alphaTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, betaTy])) primOpInfo GetCCSOfOp = mkGenPrimOp (fsLit "getCCSOf#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) primOpInfo GetCurrentCCSOp = mkGenPrimOp (fsLit "getCurrentCCS#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))-primOpInfo ClearCCSOp = mkGenPrimOp (fsLit "clearCCS#")  [deltaTyVar, alphaTyVar] [(mkFunTy (mkStatePrimTy deltaTy) ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo ClearCCSOp = mkGenPrimOp (fsLit "clearCCS#")  [deltaTyVar, alphaTyVar] [(mkVisFunTy (mkStatePrimTy deltaTy) ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) primOpInfo TraceEventOp = mkGenPrimOp (fsLit "traceEvent#")  [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo TraceEventBinaryOp = mkGenPrimOp (fsLit "traceBinaryEvent#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo TraceMarkerOp = mkGenPrimOp (fsLit "traceMarker#")  [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo GetThreadAllocationCounter = mkGenPrimOp (fsLit "getThreadAllocationCounter#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) primOpInfo SetThreadAllocationCounter = mkGenPrimOp (fsLit "setThreadAllocationCounter#")  [] [intPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo (VecBroadcastOp IntVec 16 W8) = mkGenPrimOp (fsLit "broadcastInt8X16#")  [] [intPrimTy] (int8X16PrimTy) primOpInfo (VecBroadcastOp IntVec 8 W16) = mkGenPrimOp (fsLit "broadcastInt16X8#")  [] [intPrimTy] (int16X8PrimTy)
ghc-lib/stage0/compiler/build/primop-strictness.hs-incl view
@@ -1,13 +1,13 @@ primOpStrictness CatchOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd                                                  , lazyApply2Dmd                                                  , topDmd] topRes -primOpStrictness RaiseOp =  \ _arity -> mkClosedStrictSig [topDmd] exnRes -primOpStrictness RaiseIOOp =  \ _arity -> mkClosedStrictSig [topDmd, topDmd] exnRes +primOpStrictness RaiseOp =  \ _arity -> mkClosedStrictSig [topDmd] botRes +primOpStrictness RaiseIOOp =  \ _arity -> mkClosedStrictSig [topDmd, topDmd] botRes  primOpStrictness MaskAsyncExceptionsOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes  primOpStrictness MaskUninterruptibleOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes  primOpStrictness UnmaskAsyncExceptionsOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes  primOpStrictness AtomicallyOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes -primOpStrictness RetryOp =  \ _arity -> mkClosedStrictSig [topDmd] exnRes +primOpStrictness RetryOp =  \ _arity -> mkClosedStrictSig [topDmd] botRes  primOpStrictness CatchRetryOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd                                                  , lazyApply1Dmd                                                  , topDmd ] topRes
ghc-lib/stage0/compiler/build/primop-tag.hs-incl view
@@ -1,1195 +1,1206 @@ maxPrimOpTag :: Int-maxPrimOpTag = 1192-primOpTag :: PrimOp -> Int-primOpTag CharGtOp = 1-primOpTag CharGeOp = 2-primOpTag CharEqOp = 3-primOpTag CharNeOp = 4-primOpTag CharLtOp = 5-primOpTag CharLeOp = 6-primOpTag OrdOp = 7-primOpTag IntAddOp = 8-primOpTag IntSubOp = 9-primOpTag IntMulOp = 10-primOpTag IntMulMayOfloOp = 11-primOpTag IntQuotOp = 12-primOpTag IntRemOp = 13-primOpTag IntQuotRemOp = 14-primOpTag AndIOp = 15-primOpTag OrIOp = 16-primOpTag XorIOp = 17-primOpTag NotIOp = 18-primOpTag IntNegOp = 19-primOpTag IntAddCOp = 20-primOpTag IntSubCOp = 21-primOpTag IntGtOp = 22-primOpTag IntGeOp = 23-primOpTag IntEqOp = 24-primOpTag IntNeOp = 25-primOpTag IntLtOp = 26-primOpTag IntLeOp = 27-primOpTag ChrOp = 28-primOpTag Int2WordOp = 29-primOpTag Int2FloatOp = 30-primOpTag Int2DoubleOp = 31-primOpTag Word2FloatOp = 32-primOpTag Word2DoubleOp = 33-primOpTag ISllOp = 34-primOpTag ISraOp = 35-primOpTag ISrlOp = 36-primOpTag Int8Extend = 37-primOpTag Int8Narrow = 38-primOpTag Int8NegOp = 39-primOpTag Int8AddOp = 40-primOpTag Int8SubOp = 41-primOpTag Int8MulOp = 42-primOpTag Int8QuotOp = 43-primOpTag Int8RemOp = 44-primOpTag Int8QuotRemOp = 45-primOpTag Int8EqOp = 46-primOpTag Int8GeOp = 47-primOpTag Int8GtOp = 48-primOpTag Int8LeOp = 49-primOpTag Int8LtOp = 50-primOpTag Int8NeOp = 51-primOpTag Word8Extend = 52-primOpTag Word8Narrow = 53-primOpTag Word8NotOp = 54-primOpTag Word8AddOp = 55-primOpTag Word8SubOp = 56-primOpTag Word8MulOp = 57-primOpTag Word8QuotOp = 58-primOpTag Word8RemOp = 59-primOpTag Word8QuotRemOp = 60-primOpTag Word8EqOp = 61-primOpTag Word8GeOp = 62-primOpTag Word8GtOp = 63-primOpTag Word8LeOp = 64-primOpTag Word8LtOp = 65-primOpTag Word8NeOp = 66-primOpTag Int16Extend = 67-primOpTag Int16Narrow = 68-primOpTag Int16NegOp = 69-primOpTag Int16AddOp = 70-primOpTag Int16SubOp = 71-primOpTag Int16MulOp = 72-primOpTag Int16QuotOp = 73-primOpTag Int16RemOp = 74-primOpTag Int16QuotRemOp = 75-primOpTag Int16EqOp = 76-primOpTag Int16GeOp = 77-primOpTag Int16GtOp = 78-primOpTag Int16LeOp = 79-primOpTag Int16LtOp = 80-primOpTag Int16NeOp = 81-primOpTag Word16Extend = 82-primOpTag Word16Narrow = 83-primOpTag Word16NotOp = 84-primOpTag Word16AddOp = 85-primOpTag Word16SubOp = 86-primOpTag Word16MulOp = 87-primOpTag Word16QuotOp = 88-primOpTag Word16RemOp = 89-primOpTag Word16QuotRemOp = 90-primOpTag Word16EqOp = 91-primOpTag Word16GeOp = 92-primOpTag Word16GtOp = 93-primOpTag Word16LeOp = 94-primOpTag Word16LtOp = 95-primOpTag Word16NeOp = 96-primOpTag WordAddOp = 97-primOpTag WordAddCOp = 98-primOpTag WordSubCOp = 99-primOpTag WordAdd2Op = 100-primOpTag WordSubOp = 101-primOpTag WordMulOp = 102-primOpTag WordMul2Op = 103-primOpTag WordQuotOp = 104-primOpTag WordRemOp = 105-primOpTag WordQuotRemOp = 106-primOpTag WordQuotRem2Op = 107-primOpTag AndOp = 108-primOpTag OrOp = 109-primOpTag XorOp = 110-primOpTag NotOp = 111-primOpTag SllOp = 112-primOpTag SrlOp = 113-primOpTag Word2IntOp = 114-primOpTag WordGtOp = 115-primOpTag WordGeOp = 116-primOpTag WordEqOp = 117-primOpTag WordNeOp = 118-primOpTag WordLtOp = 119-primOpTag WordLeOp = 120-primOpTag PopCnt8Op = 121-primOpTag PopCnt16Op = 122-primOpTag PopCnt32Op = 123-primOpTag PopCnt64Op = 124-primOpTag PopCntOp = 125-primOpTag Pdep8Op = 126-primOpTag Pdep16Op = 127-primOpTag Pdep32Op = 128-primOpTag Pdep64Op = 129-primOpTag PdepOp = 130-primOpTag Pext8Op = 131-primOpTag Pext16Op = 132-primOpTag Pext32Op = 133-primOpTag Pext64Op = 134-primOpTag PextOp = 135-primOpTag Clz8Op = 136-primOpTag Clz16Op = 137-primOpTag Clz32Op = 138-primOpTag Clz64Op = 139-primOpTag ClzOp = 140-primOpTag Ctz8Op = 141-primOpTag Ctz16Op = 142-primOpTag Ctz32Op = 143-primOpTag Ctz64Op = 144-primOpTag CtzOp = 145-primOpTag BSwap16Op = 146-primOpTag BSwap32Op = 147-primOpTag BSwap64Op = 148-primOpTag BSwapOp = 149-primOpTag Narrow8IntOp = 150-primOpTag Narrow16IntOp = 151-primOpTag Narrow32IntOp = 152-primOpTag Narrow8WordOp = 153-primOpTag Narrow16WordOp = 154-primOpTag Narrow32WordOp = 155-primOpTag DoubleGtOp = 156-primOpTag DoubleGeOp = 157-primOpTag DoubleEqOp = 158-primOpTag DoubleNeOp = 159-primOpTag DoubleLtOp = 160-primOpTag DoubleLeOp = 161-primOpTag DoubleAddOp = 162-primOpTag DoubleSubOp = 163-primOpTag DoubleMulOp = 164-primOpTag DoubleDivOp = 165-primOpTag DoubleNegOp = 166-primOpTag DoubleFabsOp = 167-primOpTag Double2IntOp = 168-primOpTag Double2FloatOp = 169-primOpTag DoubleExpOp = 170-primOpTag DoubleLogOp = 171-primOpTag DoubleSqrtOp = 172-primOpTag DoubleSinOp = 173-primOpTag DoubleCosOp = 174-primOpTag DoubleTanOp = 175-primOpTag DoubleAsinOp = 176-primOpTag DoubleAcosOp = 177-primOpTag DoubleAtanOp = 178-primOpTag DoubleSinhOp = 179-primOpTag DoubleCoshOp = 180-primOpTag DoubleTanhOp = 181-primOpTag DoubleAsinhOp = 182-primOpTag DoubleAcoshOp = 183-primOpTag DoubleAtanhOp = 184-primOpTag DoublePowerOp = 185-primOpTag DoubleDecode_2IntOp = 186-primOpTag DoubleDecode_Int64Op = 187-primOpTag FloatGtOp = 188-primOpTag FloatGeOp = 189-primOpTag FloatEqOp = 190-primOpTag FloatNeOp = 191-primOpTag FloatLtOp = 192-primOpTag FloatLeOp = 193-primOpTag FloatAddOp = 194-primOpTag FloatSubOp = 195-primOpTag FloatMulOp = 196-primOpTag FloatDivOp = 197-primOpTag FloatNegOp = 198-primOpTag FloatFabsOp = 199-primOpTag Float2IntOp = 200-primOpTag FloatExpOp = 201-primOpTag FloatLogOp = 202-primOpTag FloatSqrtOp = 203-primOpTag FloatSinOp = 204-primOpTag FloatCosOp = 205-primOpTag FloatTanOp = 206-primOpTag FloatAsinOp = 207-primOpTag FloatAcosOp = 208-primOpTag FloatAtanOp = 209-primOpTag FloatSinhOp = 210-primOpTag FloatCoshOp = 211-primOpTag FloatTanhOp = 212-primOpTag FloatAsinhOp = 213-primOpTag FloatAcoshOp = 214-primOpTag FloatAtanhOp = 215-primOpTag FloatPowerOp = 216-primOpTag Float2DoubleOp = 217-primOpTag FloatDecode_IntOp = 218-primOpTag NewArrayOp = 219-primOpTag SameMutableArrayOp = 220-primOpTag ReadArrayOp = 221-primOpTag WriteArrayOp = 222-primOpTag SizeofArrayOp = 223-primOpTag SizeofMutableArrayOp = 224-primOpTag IndexArrayOp = 225-primOpTag UnsafeFreezeArrayOp = 226-primOpTag UnsafeThawArrayOp = 227-primOpTag CopyArrayOp = 228-primOpTag CopyMutableArrayOp = 229-primOpTag CloneArrayOp = 230-primOpTag CloneMutableArrayOp = 231-primOpTag FreezeArrayOp = 232-primOpTag ThawArrayOp = 233-primOpTag CasArrayOp = 234-primOpTag NewSmallArrayOp = 235-primOpTag SameSmallMutableArrayOp = 236-primOpTag ReadSmallArrayOp = 237-primOpTag WriteSmallArrayOp = 238-primOpTag SizeofSmallArrayOp = 239-primOpTag SizeofSmallMutableArrayOp = 240-primOpTag IndexSmallArrayOp = 241-primOpTag UnsafeFreezeSmallArrayOp = 242-primOpTag UnsafeThawSmallArrayOp = 243-primOpTag CopySmallArrayOp = 244-primOpTag CopySmallMutableArrayOp = 245-primOpTag CloneSmallArrayOp = 246-primOpTag CloneSmallMutableArrayOp = 247-primOpTag FreezeSmallArrayOp = 248-primOpTag ThawSmallArrayOp = 249-primOpTag CasSmallArrayOp = 250-primOpTag NewByteArrayOp_Char = 251-primOpTag NewPinnedByteArrayOp_Char = 252-primOpTag NewAlignedPinnedByteArrayOp_Char = 253-primOpTag MutableByteArrayIsPinnedOp = 254-primOpTag ByteArrayIsPinnedOp = 255-primOpTag ByteArrayContents_Char = 256-primOpTag SameMutableByteArrayOp = 257-primOpTag ShrinkMutableByteArrayOp_Char = 258-primOpTag ResizeMutableByteArrayOp_Char = 259-primOpTag UnsafeFreezeByteArrayOp = 260-primOpTag SizeofByteArrayOp = 261-primOpTag SizeofMutableByteArrayOp = 262-primOpTag GetSizeofMutableByteArrayOp = 263-primOpTag IndexByteArrayOp_Char = 264-primOpTag IndexByteArrayOp_WideChar = 265-primOpTag IndexByteArrayOp_Int = 266-primOpTag IndexByteArrayOp_Word = 267-primOpTag IndexByteArrayOp_Addr = 268-primOpTag IndexByteArrayOp_Float = 269-primOpTag IndexByteArrayOp_Double = 270-primOpTag IndexByteArrayOp_StablePtr = 271-primOpTag IndexByteArrayOp_Int8 = 272-primOpTag IndexByteArrayOp_Int16 = 273-primOpTag IndexByteArrayOp_Int32 = 274-primOpTag IndexByteArrayOp_Int64 = 275-primOpTag IndexByteArrayOp_Word8 = 276-primOpTag IndexByteArrayOp_Word16 = 277-primOpTag IndexByteArrayOp_Word32 = 278-primOpTag IndexByteArrayOp_Word64 = 279-primOpTag IndexByteArrayOp_Word8AsChar = 280-primOpTag IndexByteArrayOp_Word8AsWideChar = 281-primOpTag IndexByteArrayOp_Word8AsAddr = 282-primOpTag IndexByteArrayOp_Word8AsFloat = 283-primOpTag IndexByteArrayOp_Word8AsDouble = 284-primOpTag IndexByteArrayOp_Word8AsStablePtr = 285-primOpTag IndexByteArrayOp_Word8AsInt16 = 286-primOpTag IndexByteArrayOp_Word8AsInt32 = 287-primOpTag IndexByteArrayOp_Word8AsInt64 = 288-primOpTag IndexByteArrayOp_Word8AsInt = 289-primOpTag IndexByteArrayOp_Word8AsWord16 = 290-primOpTag IndexByteArrayOp_Word8AsWord32 = 291-primOpTag IndexByteArrayOp_Word8AsWord64 = 292-primOpTag IndexByteArrayOp_Word8AsWord = 293-primOpTag ReadByteArrayOp_Char = 294-primOpTag ReadByteArrayOp_WideChar = 295-primOpTag ReadByteArrayOp_Int = 296-primOpTag ReadByteArrayOp_Word = 297-primOpTag ReadByteArrayOp_Addr = 298-primOpTag ReadByteArrayOp_Float = 299-primOpTag ReadByteArrayOp_Double = 300-primOpTag ReadByteArrayOp_StablePtr = 301-primOpTag ReadByteArrayOp_Int8 = 302-primOpTag ReadByteArrayOp_Int16 = 303-primOpTag ReadByteArrayOp_Int32 = 304-primOpTag ReadByteArrayOp_Int64 = 305-primOpTag ReadByteArrayOp_Word8 = 306-primOpTag ReadByteArrayOp_Word16 = 307-primOpTag ReadByteArrayOp_Word32 = 308-primOpTag ReadByteArrayOp_Word64 = 309-primOpTag ReadByteArrayOp_Word8AsChar = 310-primOpTag ReadByteArrayOp_Word8AsWideChar = 311-primOpTag ReadByteArrayOp_Word8AsAddr = 312-primOpTag ReadByteArrayOp_Word8AsFloat = 313-primOpTag ReadByteArrayOp_Word8AsDouble = 314-primOpTag ReadByteArrayOp_Word8AsStablePtr = 315-primOpTag ReadByteArrayOp_Word8AsInt16 = 316-primOpTag ReadByteArrayOp_Word8AsInt32 = 317-primOpTag ReadByteArrayOp_Word8AsInt64 = 318-primOpTag ReadByteArrayOp_Word8AsInt = 319-primOpTag ReadByteArrayOp_Word8AsWord16 = 320-primOpTag ReadByteArrayOp_Word8AsWord32 = 321-primOpTag ReadByteArrayOp_Word8AsWord64 = 322-primOpTag ReadByteArrayOp_Word8AsWord = 323-primOpTag WriteByteArrayOp_Char = 324-primOpTag WriteByteArrayOp_WideChar = 325-primOpTag WriteByteArrayOp_Int = 326-primOpTag WriteByteArrayOp_Word = 327-primOpTag WriteByteArrayOp_Addr = 328-primOpTag WriteByteArrayOp_Float = 329-primOpTag WriteByteArrayOp_Double = 330-primOpTag WriteByteArrayOp_StablePtr = 331-primOpTag WriteByteArrayOp_Int8 = 332-primOpTag WriteByteArrayOp_Int16 = 333-primOpTag WriteByteArrayOp_Int32 = 334-primOpTag WriteByteArrayOp_Int64 = 335-primOpTag WriteByteArrayOp_Word8 = 336-primOpTag WriteByteArrayOp_Word16 = 337-primOpTag WriteByteArrayOp_Word32 = 338-primOpTag WriteByteArrayOp_Word64 = 339-primOpTag WriteByteArrayOp_Word8AsChar = 340-primOpTag WriteByteArrayOp_Word8AsWideChar = 341-primOpTag WriteByteArrayOp_Word8AsAddr = 342-primOpTag WriteByteArrayOp_Word8AsFloat = 343-primOpTag WriteByteArrayOp_Word8AsDouble = 344-primOpTag WriteByteArrayOp_Word8AsStablePtr = 345-primOpTag WriteByteArrayOp_Word8AsInt16 = 346-primOpTag WriteByteArrayOp_Word8AsInt32 = 347-primOpTag WriteByteArrayOp_Word8AsInt64 = 348-primOpTag WriteByteArrayOp_Word8AsInt = 349-primOpTag WriteByteArrayOp_Word8AsWord16 = 350-primOpTag WriteByteArrayOp_Word8AsWord32 = 351-primOpTag WriteByteArrayOp_Word8AsWord64 = 352-primOpTag WriteByteArrayOp_Word8AsWord = 353-primOpTag CompareByteArraysOp = 354-primOpTag CopyByteArrayOp = 355-primOpTag CopyMutableByteArrayOp = 356-primOpTag CopyByteArrayToAddrOp = 357-primOpTag CopyMutableByteArrayToAddrOp = 358-primOpTag CopyAddrToByteArrayOp = 359-primOpTag SetByteArrayOp = 360-primOpTag AtomicReadByteArrayOp_Int = 361-primOpTag AtomicWriteByteArrayOp_Int = 362-primOpTag CasByteArrayOp_Int = 363-primOpTag FetchAddByteArrayOp_Int = 364-primOpTag FetchSubByteArrayOp_Int = 365-primOpTag FetchAndByteArrayOp_Int = 366-primOpTag FetchNandByteArrayOp_Int = 367-primOpTag FetchOrByteArrayOp_Int = 368-primOpTag FetchXorByteArrayOp_Int = 369-primOpTag NewArrayArrayOp = 370-primOpTag SameMutableArrayArrayOp = 371-primOpTag UnsafeFreezeArrayArrayOp = 372-primOpTag SizeofArrayArrayOp = 373-primOpTag SizeofMutableArrayArrayOp = 374-primOpTag IndexArrayArrayOp_ByteArray = 375-primOpTag IndexArrayArrayOp_ArrayArray = 376-primOpTag ReadArrayArrayOp_ByteArray = 377-primOpTag ReadArrayArrayOp_MutableByteArray = 378-primOpTag ReadArrayArrayOp_ArrayArray = 379-primOpTag ReadArrayArrayOp_MutableArrayArray = 380-primOpTag WriteArrayArrayOp_ByteArray = 381-primOpTag WriteArrayArrayOp_MutableByteArray = 382-primOpTag WriteArrayArrayOp_ArrayArray = 383-primOpTag WriteArrayArrayOp_MutableArrayArray = 384-primOpTag CopyArrayArrayOp = 385-primOpTag CopyMutableArrayArrayOp = 386-primOpTag AddrAddOp = 387-primOpTag AddrSubOp = 388-primOpTag AddrRemOp = 389-primOpTag Addr2IntOp = 390-primOpTag Int2AddrOp = 391-primOpTag AddrGtOp = 392-primOpTag AddrGeOp = 393-primOpTag AddrEqOp = 394-primOpTag AddrNeOp = 395-primOpTag AddrLtOp = 396-primOpTag AddrLeOp = 397-primOpTag IndexOffAddrOp_Char = 398-primOpTag IndexOffAddrOp_WideChar = 399-primOpTag IndexOffAddrOp_Int = 400-primOpTag IndexOffAddrOp_Word = 401-primOpTag IndexOffAddrOp_Addr = 402-primOpTag IndexOffAddrOp_Float = 403-primOpTag IndexOffAddrOp_Double = 404-primOpTag IndexOffAddrOp_StablePtr = 405-primOpTag IndexOffAddrOp_Int8 = 406-primOpTag IndexOffAddrOp_Int16 = 407-primOpTag IndexOffAddrOp_Int32 = 408-primOpTag IndexOffAddrOp_Int64 = 409-primOpTag IndexOffAddrOp_Word8 = 410-primOpTag IndexOffAddrOp_Word16 = 411-primOpTag IndexOffAddrOp_Word32 = 412-primOpTag IndexOffAddrOp_Word64 = 413-primOpTag ReadOffAddrOp_Char = 414-primOpTag ReadOffAddrOp_WideChar = 415-primOpTag ReadOffAddrOp_Int = 416-primOpTag ReadOffAddrOp_Word = 417-primOpTag ReadOffAddrOp_Addr = 418-primOpTag ReadOffAddrOp_Float = 419-primOpTag ReadOffAddrOp_Double = 420-primOpTag ReadOffAddrOp_StablePtr = 421-primOpTag ReadOffAddrOp_Int8 = 422-primOpTag ReadOffAddrOp_Int16 = 423-primOpTag ReadOffAddrOp_Int32 = 424-primOpTag ReadOffAddrOp_Int64 = 425-primOpTag ReadOffAddrOp_Word8 = 426-primOpTag ReadOffAddrOp_Word16 = 427-primOpTag ReadOffAddrOp_Word32 = 428-primOpTag ReadOffAddrOp_Word64 = 429-primOpTag WriteOffAddrOp_Char = 430-primOpTag WriteOffAddrOp_WideChar = 431-primOpTag WriteOffAddrOp_Int = 432-primOpTag WriteOffAddrOp_Word = 433-primOpTag WriteOffAddrOp_Addr = 434-primOpTag WriteOffAddrOp_Float = 435-primOpTag WriteOffAddrOp_Double = 436-primOpTag WriteOffAddrOp_StablePtr = 437-primOpTag WriteOffAddrOp_Int8 = 438-primOpTag WriteOffAddrOp_Int16 = 439-primOpTag WriteOffAddrOp_Int32 = 440-primOpTag WriteOffAddrOp_Int64 = 441-primOpTag WriteOffAddrOp_Word8 = 442-primOpTag WriteOffAddrOp_Word16 = 443-primOpTag WriteOffAddrOp_Word32 = 444-primOpTag WriteOffAddrOp_Word64 = 445-primOpTag NewMutVarOp = 446-primOpTag ReadMutVarOp = 447-primOpTag WriteMutVarOp = 448-primOpTag SameMutVarOp = 449-primOpTag AtomicModifyMutVar2Op = 450-primOpTag AtomicModifyMutVar_Op = 451-primOpTag CasMutVarOp = 452-primOpTag CatchOp = 453-primOpTag RaiseOp = 454-primOpTag RaiseIOOp = 455-primOpTag MaskAsyncExceptionsOp = 456-primOpTag MaskUninterruptibleOp = 457-primOpTag UnmaskAsyncExceptionsOp = 458-primOpTag MaskStatus = 459-primOpTag AtomicallyOp = 460-primOpTag RetryOp = 461-primOpTag CatchRetryOp = 462-primOpTag CatchSTMOp = 463-primOpTag NewTVarOp = 464-primOpTag ReadTVarOp = 465-primOpTag ReadTVarIOOp = 466-primOpTag WriteTVarOp = 467-primOpTag SameTVarOp = 468-primOpTag NewMVarOp = 469-primOpTag TakeMVarOp = 470-primOpTag TryTakeMVarOp = 471-primOpTag PutMVarOp = 472-primOpTag TryPutMVarOp = 473-primOpTag ReadMVarOp = 474-primOpTag TryReadMVarOp = 475-primOpTag SameMVarOp = 476-primOpTag IsEmptyMVarOp = 477-primOpTag DelayOp = 478-primOpTag WaitReadOp = 479-primOpTag WaitWriteOp = 480-primOpTag ForkOp = 481-primOpTag ForkOnOp = 482-primOpTag KillThreadOp = 483-primOpTag YieldOp = 484-primOpTag MyThreadIdOp = 485-primOpTag LabelThreadOp = 486-primOpTag IsCurrentThreadBoundOp = 487-primOpTag NoDuplicateOp = 488-primOpTag ThreadStatusOp = 489-primOpTag MkWeakOp = 490-primOpTag MkWeakNoFinalizerOp = 491-primOpTag AddCFinalizerToWeakOp = 492-primOpTag DeRefWeakOp = 493-primOpTag FinalizeWeakOp = 494-primOpTag TouchOp = 495-primOpTag MakeStablePtrOp = 496-primOpTag DeRefStablePtrOp = 497-primOpTag EqStablePtrOp = 498-primOpTag MakeStableNameOp = 499-primOpTag EqStableNameOp = 500-primOpTag StableNameToIntOp = 501-primOpTag CompactNewOp = 502-primOpTag CompactResizeOp = 503-primOpTag CompactContainsOp = 504-primOpTag CompactContainsAnyOp = 505-primOpTag CompactGetFirstBlockOp = 506-primOpTag CompactGetNextBlockOp = 507-primOpTag CompactAllocateBlockOp = 508-primOpTag CompactFixupPointersOp = 509-primOpTag CompactAdd = 510-primOpTag CompactAddWithSharing = 511-primOpTag CompactSize = 512-primOpTag ReallyUnsafePtrEqualityOp = 513-primOpTag ParOp = 514-primOpTag SparkOp = 515-primOpTag SeqOp = 516-primOpTag GetSparkOp = 517-primOpTag NumSparks = 518-primOpTag DataToTagOp = 519-primOpTag TagToEnumOp = 520-primOpTag AddrToAnyOp = 521-primOpTag AnyToAddrOp = 522-primOpTag MkApUpd0_Op = 523-primOpTag NewBCOOp = 524-primOpTag UnpackClosureOp = 525-primOpTag GetApStackValOp = 526-primOpTag GetCCSOfOp = 527-primOpTag GetCurrentCCSOp = 528-primOpTag ClearCCSOp = 529-primOpTag TraceEventOp = 530-primOpTag TraceEventBinaryOp = 531-primOpTag TraceMarkerOp = 532-primOpTag GetThreadAllocationCounter = 533-primOpTag SetThreadAllocationCounter = 534-primOpTag (VecBroadcastOp IntVec 16 W8) = 535-primOpTag (VecBroadcastOp IntVec 8 W16) = 536-primOpTag (VecBroadcastOp IntVec 4 W32) = 537-primOpTag (VecBroadcastOp IntVec 2 W64) = 538-primOpTag (VecBroadcastOp IntVec 32 W8) = 539-primOpTag (VecBroadcastOp IntVec 16 W16) = 540-primOpTag (VecBroadcastOp IntVec 8 W32) = 541-primOpTag (VecBroadcastOp IntVec 4 W64) = 542-primOpTag (VecBroadcastOp IntVec 64 W8) = 543-primOpTag (VecBroadcastOp IntVec 32 W16) = 544-primOpTag (VecBroadcastOp IntVec 16 W32) = 545-primOpTag (VecBroadcastOp IntVec 8 W64) = 546-primOpTag (VecBroadcastOp WordVec 16 W8) = 547-primOpTag (VecBroadcastOp WordVec 8 W16) = 548-primOpTag (VecBroadcastOp WordVec 4 W32) = 549-primOpTag (VecBroadcastOp WordVec 2 W64) = 550-primOpTag (VecBroadcastOp WordVec 32 W8) = 551-primOpTag (VecBroadcastOp WordVec 16 W16) = 552-primOpTag (VecBroadcastOp WordVec 8 W32) = 553-primOpTag (VecBroadcastOp WordVec 4 W64) = 554-primOpTag (VecBroadcastOp WordVec 64 W8) = 555-primOpTag (VecBroadcastOp WordVec 32 W16) = 556-primOpTag (VecBroadcastOp WordVec 16 W32) = 557-primOpTag (VecBroadcastOp WordVec 8 W64) = 558-primOpTag (VecBroadcastOp FloatVec 4 W32) = 559-primOpTag (VecBroadcastOp FloatVec 2 W64) = 560-primOpTag (VecBroadcastOp FloatVec 8 W32) = 561-primOpTag (VecBroadcastOp FloatVec 4 W64) = 562-primOpTag (VecBroadcastOp FloatVec 16 W32) = 563-primOpTag (VecBroadcastOp FloatVec 8 W64) = 564-primOpTag (VecPackOp IntVec 16 W8) = 565-primOpTag (VecPackOp IntVec 8 W16) = 566-primOpTag (VecPackOp IntVec 4 W32) = 567-primOpTag (VecPackOp IntVec 2 W64) = 568-primOpTag (VecPackOp IntVec 32 W8) = 569-primOpTag (VecPackOp IntVec 16 W16) = 570-primOpTag (VecPackOp IntVec 8 W32) = 571-primOpTag (VecPackOp IntVec 4 W64) = 572-primOpTag (VecPackOp IntVec 64 W8) = 573-primOpTag (VecPackOp IntVec 32 W16) = 574-primOpTag (VecPackOp IntVec 16 W32) = 575-primOpTag (VecPackOp IntVec 8 W64) = 576-primOpTag (VecPackOp WordVec 16 W8) = 577-primOpTag (VecPackOp WordVec 8 W16) = 578-primOpTag (VecPackOp WordVec 4 W32) = 579-primOpTag (VecPackOp WordVec 2 W64) = 580-primOpTag (VecPackOp WordVec 32 W8) = 581-primOpTag (VecPackOp WordVec 16 W16) = 582-primOpTag (VecPackOp WordVec 8 W32) = 583-primOpTag (VecPackOp WordVec 4 W64) = 584-primOpTag (VecPackOp WordVec 64 W8) = 585-primOpTag (VecPackOp WordVec 32 W16) = 586-primOpTag (VecPackOp WordVec 16 W32) = 587-primOpTag (VecPackOp WordVec 8 W64) = 588-primOpTag (VecPackOp FloatVec 4 W32) = 589-primOpTag (VecPackOp FloatVec 2 W64) = 590-primOpTag (VecPackOp FloatVec 8 W32) = 591-primOpTag (VecPackOp FloatVec 4 W64) = 592-primOpTag (VecPackOp FloatVec 16 W32) = 593-primOpTag (VecPackOp FloatVec 8 W64) = 594-primOpTag (VecUnpackOp IntVec 16 W8) = 595-primOpTag (VecUnpackOp IntVec 8 W16) = 596-primOpTag (VecUnpackOp IntVec 4 W32) = 597-primOpTag (VecUnpackOp IntVec 2 W64) = 598-primOpTag (VecUnpackOp IntVec 32 W8) = 599-primOpTag (VecUnpackOp IntVec 16 W16) = 600-primOpTag (VecUnpackOp IntVec 8 W32) = 601-primOpTag (VecUnpackOp IntVec 4 W64) = 602-primOpTag (VecUnpackOp IntVec 64 W8) = 603-primOpTag (VecUnpackOp IntVec 32 W16) = 604-primOpTag (VecUnpackOp IntVec 16 W32) = 605-primOpTag (VecUnpackOp IntVec 8 W64) = 606-primOpTag (VecUnpackOp WordVec 16 W8) = 607-primOpTag (VecUnpackOp WordVec 8 W16) = 608-primOpTag (VecUnpackOp WordVec 4 W32) = 609-primOpTag (VecUnpackOp WordVec 2 W64) = 610-primOpTag (VecUnpackOp WordVec 32 W8) = 611-primOpTag (VecUnpackOp WordVec 16 W16) = 612-primOpTag (VecUnpackOp WordVec 8 W32) = 613-primOpTag (VecUnpackOp WordVec 4 W64) = 614-primOpTag (VecUnpackOp WordVec 64 W8) = 615-primOpTag (VecUnpackOp WordVec 32 W16) = 616-primOpTag (VecUnpackOp WordVec 16 W32) = 617-primOpTag (VecUnpackOp WordVec 8 W64) = 618-primOpTag (VecUnpackOp FloatVec 4 W32) = 619-primOpTag (VecUnpackOp FloatVec 2 W64) = 620-primOpTag (VecUnpackOp FloatVec 8 W32) = 621-primOpTag (VecUnpackOp FloatVec 4 W64) = 622-primOpTag (VecUnpackOp FloatVec 16 W32) = 623-primOpTag (VecUnpackOp FloatVec 8 W64) = 624-primOpTag (VecInsertOp IntVec 16 W8) = 625-primOpTag (VecInsertOp IntVec 8 W16) = 626-primOpTag (VecInsertOp IntVec 4 W32) = 627-primOpTag (VecInsertOp IntVec 2 W64) = 628-primOpTag (VecInsertOp IntVec 32 W8) = 629-primOpTag (VecInsertOp IntVec 16 W16) = 630-primOpTag (VecInsertOp IntVec 8 W32) = 631-primOpTag (VecInsertOp IntVec 4 W64) = 632-primOpTag (VecInsertOp IntVec 64 W8) = 633-primOpTag (VecInsertOp IntVec 32 W16) = 634-primOpTag (VecInsertOp IntVec 16 W32) = 635-primOpTag (VecInsertOp IntVec 8 W64) = 636-primOpTag (VecInsertOp WordVec 16 W8) = 637-primOpTag (VecInsertOp WordVec 8 W16) = 638-primOpTag (VecInsertOp WordVec 4 W32) = 639-primOpTag (VecInsertOp WordVec 2 W64) = 640-primOpTag (VecInsertOp WordVec 32 W8) = 641-primOpTag (VecInsertOp WordVec 16 W16) = 642-primOpTag (VecInsertOp WordVec 8 W32) = 643-primOpTag (VecInsertOp WordVec 4 W64) = 644-primOpTag (VecInsertOp WordVec 64 W8) = 645-primOpTag (VecInsertOp WordVec 32 W16) = 646-primOpTag (VecInsertOp WordVec 16 W32) = 647-primOpTag (VecInsertOp WordVec 8 W64) = 648-primOpTag (VecInsertOp FloatVec 4 W32) = 649-primOpTag (VecInsertOp FloatVec 2 W64) = 650-primOpTag (VecInsertOp FloatVec 8 W32) = 651-primOpTag (VecInsertOp FloatVec 4 W64) = 652-primOpTag (VecInsertOp FloatVec 16 W32) = 653-primOpTag (VecInsertOp FloatVec 8 W64) = 654-primOpTag (VecAddOp IntVec 16 W8) = 655-primOpTag (VecAddOp IntVec 8 W16) = 656-primOpTag (VecAddOp IntVec 4 W32) = 657-primOpTag (VecAddOp IntVec 2 W64) = 658-primOpTag (VecAddOp IntVec 32 W8) = 659-primOpTag (VecAddOp IntVec 16 W16) = 660-primOpTag (VecAddOp IntVec 8 W32) = 661-primOpTag (VecAddOp IntVec 4 W64) = 662-primOpTag (VecAddOp IntVec 64 W8) = 663-primOpTag (VecAddOp IntVec 32 W16) = 664-primOpTag (VecAddOp IntVec 16 W32) = 665-primOpTag (VecAddOp IntVec 8 W64) = 666-primOpTag (VecAddOp WordVec 16 W8) = 667-primOpTag (VecAddOp WordVec 8 W16) = 668-primOpTag (VecAddOp WordVec 4 W32) = 669-primOpTag (VecAddOp WordVec 2 W64) = 670-primOpTag (VecAddOp WordVec 32 W8) = 671-primOpTag (VecAddOp WordVec 16 W16) = 672-primOpTag (VecAddOp WordVec 8 W32) = 673-primOpTag (VecAddOp WordVec 4 W64) = 674-primOpTag (VecAddOp WordVec 64 W8) = 675-primOpTag (VecAddOp WordVec 32 W16) = 676-primOpTag (VecAddOp WordVec 16 W32) = 677-primOpTag (VecAddOp WordVec 8 W64) = 678-primOpTag (VecAddOp FloatVec 4 W32) = 679-primOpTag (VecAddOp FloatVec 2 W64) = 680-primOpTag (VecAddOp FloatVec 8 W32) = 681-primOpTag (VecAddOp FloatVec 4 W64) = 682-primOpTag (VecAddOp FloatVec 16 W32) = 683-primOpTag (VecAddOp FloatVec 8 W64) = 684-primOpTag (VecSubOp IntVec 16 W8) = 685-primOpTag (VecSubOp IntVec 8 W16) = 686-primOpTag (VecSubOp IntVec 4 W32) = 687-primOpTag (VecSubOp IntVec 2 W64) = 688-primOpTag (VecSubOp IntVec 32 W8) = 689-primOpTag (VecSubOp IntVec 16 W16) = 690-primOpTag (VecSubOp IntVec 8 W32) = 691-primOpTag (VecSubOp IntVec 4 W64) = 692-primOpTag (VecSubOp IntVec 64 W8) = 693-primOpTag (VecSubOp IntVec 32 W16) = 694-primOpTag (VecSubOp IntVec 16 W32) = 695-primOpTag (VecSubOp IntVec 8 W64) = 696-primOpTag (VecSubOp WordVec 16 W8) = 697-primOpTag (VecSubOp WordVec 8 W16) = 698-primOpTag (VecSubOp WordVec 4 W32) = 699-primOpTag (VecSubOp WordVec 2 W64) = 700-primOpTag (VecSubOp WordVec 32 W8) = 701-primOpTag (VecSubOp WordVec 16 W16) = 702-primOpTag (VecSubOp WordVec 8 W32) = 703-primOpTag (VecSubOp WordVec 4 W64) = 704-primOpTag (VecSubOp WordVec 64 W8) = 705-primOpTag (VecSubOp WordVec 32 W16) = 706-primOpTag (VecSubOp WordVec 16 W32) = 707-primOpTag (VecSubOp WordVec 8 W64) = 708-primOpTag (VecSubOp FloatVec 4 W32) = 709-primOpTag (VecSubOp FloatVec 2 W64) = 710-primOpTag (VecSubOp FloatVec 8 W32) = 711-primOpTag (VecSubOp FloatVec 4 W64) = 712-primOpTag (VecSubOp FloatVec 16 W32) = 713-primOpTag (VecSubOp FloatVec 8 W64) = 714-primOpTag (VecMulOp IntVec 16 W8) = 715-primOpTag (VecMulOp IntVec 8 W16) = 716-primOpTag (VecMulOp IntVec 4 W32) = 717-primOpTag (VecMulOp IntVec 2 W64) = 718-primOpTag (VecMulOp IntVec 32 W8) = 719-primOpTag (VecMulOp IntVec 16 W16) = 720-primOpTag (VecMulOp IntVec 8 W32) = 721-primOpTag (VecMulOp IntVec 4 W64) = 722-primOpTag (VecMulOp IntVec 64 W8) = 723-primOpTag (VecMulOp IntVec 32 W16) = 724-primOpTag (VecMulOp IntVec 16 W32) = 725-primOpTag (VecMulOp IntVec 8 W64) = 726-primOpTag (VecMulOp WordVec 16 W8) = 727-primOpTag (VecMulOp WordVec 8 W16) = 728-primOpTag (VecMulOp WordVec 4 W32) = 729-primOpTag (VecMulOp WordVec 2 W64) = 730-primOpTag (VecMulOp WordVec 32 W8) = 731-primOpTag (VecMulOp WordVec 16 W16) = 732-primOpTag (VecMulOp WordVec 8 W32) = 733-primOpTag (VecMulOp WordVec 4 W64) = 734-primOpTag (VecMulOp WordVec 64 W8) = 735-primOpTag (VecMulOp WordVec 32 W16) = 736-primOpTag (VecMulOp WordVec 16 W32) = 737-primOpTag (VecMulOp WordVec 8 W64) = 738-primOpTag (VecMulOp FloatVec 4 W32) = 739-primOpTag (VecMulOp FloatVec 2 W64) = 740-primOpTag (VecMulOp FloatVec 8 W32) = 741-primOpTag (VecMulOp FloatVec 4 W64) = 742-primOpTag (VecMulOp FloatVec 16 W32) = 743-primOpTag (VecMulOp FloatVec 8 W64) = 744-primOpTag (VecDivOp FloatVec 4 W32) = 745-primOpTag (VecDivOp FloatVec 2 W64) = 746-primOpTag (VecDivOp FloatVec 8 W32) = 747-primOpTag (VecDivOp FloatVec 4 W64) = 748-primOpTag (VecDivOp FloatVec 16 W32) = 749-primOpTag (VecDivOp FloatVec 8 W64) = 750-primOpTag (VecQuotOp IntVec 16 W8) = 751-primOpTag (VecQuotOp IntVec 8 W16) = 752-primOpTag (VecQuotOp IntVec 4 W32) = 753-primOpTag (VecQuotOp IntVec 2 W64) = 754-primOpTag (VecQuotOp IntVec 32 W8) = 755-primOpTag (VecQuotOp IntVec 16 W16) = 756-primOpTag (VecQuotOp IntVec 8 W32) = 757-primOpTag (VecQuotOp IntVec 4 W64) = 758-primOpTag (VecQuotOp IntVec 64 W8) = 759-primOpTag (VecQuotOp IntVec 32 W16) = 760-primOpTag (VecQuotOp IntVec 16 W32) = 761-primOpTag (VecQuotOp IntVec 8 W64) = 762-primOpTag (VecQuotOp WordVec 16 W8) = 763-primOpTag (VecQuotOp WordVec 8 W16) = 764-primOpTag (VecQuotOp WordVec 4 W32) = 765-primOpTag (VecQuotOp WordVec 2 W64) = 766-primOpTag (VecQuotOp WordVec 32 W8) = 767-primOpTag (VecQuotOp WordVec 16 W16) = 768-primOpTag (VecQuotOp WordVec 8 W32) = 769-primOpTag (VecQuotOp WordVec 4 W64) = 770-primOpTag (VecQuotOp WordVec 64 W8) = 771-primOpTag (VecQuotOp WordVec 32 W16) = 772-primOpTag (VecQuotOp WordVec 16 W32) = 773-primOpTag (VecQuotOp WordVec 8 W64) = 774-primOpTag (VecRemOp IntVec 16 W8) = 775-primOpTag (VecRemOp IntVec 8 W16) = 776-primOpTag (VecRemOp IntVec 4 W32) = 777-primOpTag (VecRemOp IntVec 2 W64) = 778-primOpTag (VecRemOp IntVec 32 W8) = 779-primOpTag (VecRemOp IntVec 16 W16) = 780-primOpTag (VecRemOp IntVec 8 W32) = 781-primOpTag (VecRemOp IntVec 4 W64) = 782-primOpTag (VecRemOp IntVec 64 W8) = 783-primOpTag (VecRemOp IntVec 32 W16) = 784-primOpTag (VecRemOp IntVec 16 W32) = 785-primOpTag (VecRemOp IntVec 8 W64) = 786-primOpTag (VecRemOp WordVec 16 W8) = 787-primOpTag (VecRemOp WordVec 8 W16) = 788-primOpTag (VecRemOp WordVec 4 W32) = 789-primOpTag (VecRemOp WordVec 2 W64) = 790-primOpTag (VecRemOp WordVec 32 W8) = 791-primOpTag (VecRemOp WordVec 16 W16) = 792-primOpTag (VecRemOp WordVec 8 W32) = 793-primOpTag (VecRemOp WordVec 4 W64) = 794-primOpTag (VecRemOp WordVec 64 W8) = 795-primOpTag (VecRemOp WordVec 32 W16) = 796-primOpTag (VecRemOp WordVec 16 W32) = 797-primOpTag (VecRemOp WordVec 8 W64) = 798-primOpTag (VecNegOp IntVec 16 W8) = 799-primOpTag (VecNegOp IntVec 8 W16) = 800-primOpTag (VecNegOp IntVec 4 W32) = 801-primOpTag (VecNegOp IntVec 2 W64) = 802-primOpTag (VecNegOp IntVec 32 W8) = 803-primOpTag (VecNegOp IntVec 16 W16) = 804-primOpTag (VecNegOp IntVec 8 W32) = 805-primOpTag (VecNegOp IntVec 4 W64) = 806-primOpTag (VecNegOp IntVec 64 W8) = 807-primOpTag (VecNegOp IntVec 32 W16) = 808-primOpTag (VecNegOp IntVec 16 W32) = 809-primOpTag (VecNegOp IntVec 8 W64) = 810-primOpTag (VecNegOp FloatVec 4 W32) = 811-primOpTag (VecNegOp FloatVec 2 W64) = 812-primOpTag (VecNegOp FloatVec 8 W32) = 813-primOpTag (VecNegOp FloatVec 4 W64) = 814-primOpTag (VecNegOp FloatVec 16 W32) = 815-primOpTag (VecNegOp FloatVec 8 W64) = 816-primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 817-primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 818-primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 819-primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 820-primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 821-primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 822-primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 823-primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 824-primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 825-primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 826-primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 827-primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 828-primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 829-primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 830-primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 831-primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 832-primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 833-primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 834-primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 835-primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 836-primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 837-primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 838-primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 839-primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 840-primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 841-primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 842-primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 843-primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 844-primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 845-primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 846-primOpTag (VecReadByteArrayOp IntVec 16 W8) = 847-primOpTag (VecReadByteArrayOp IntVec 8 W16) = 848-primOpTag (VecReadByteArrayOp IntVec 4 W32) = 849-primOpTag (VecReadByteArrayOp IntVec 2 W64) = 850-primOpTag (VecReadByteArrayOp IntVec 32 W8) = 851-primOpTag (VecReadByteArrayOp IntVec 16 W16) = 852-primOpTag (VecReadByteArrayOp IntVec 8 W32) = 853-primOpTag (VecReadByteArrayOp IntVec 4 W64) = 854-primOpTag (VecReadByteArrayOp IntVec 64 W8) = 855-primOpTag (VecReadByteArrayOp IntVec 32 W16) = 856-primOpTag (VecReadByteArrayOp IntVec 16 W32) = 857-primOpTag (VecReadByteArrayOp IntVec 8 W64) = 858-primOpTag (VecReadByteArrayOp WordVec 16 W8) = 859-primOpTag (VecReadByteArrayOp WordVec 8 W16) = 860-primOpTag (VecReadByteArrayOp WordVec 4 W32) = 861-primOpTag (VecReadByteArrayOp WordVec 2 W64) = 862-primOpTag (VecReadByteArrayOp WordVec 32 W8) = 863-primOpTag (VecReadByteArrayOp WordVec 16 W16) = 864-primOpTag (VecReadByteArrayOp WordVec 8 W32) = 865-primOpTag (VecReadByteArrayOp WordVec 4 W64) = 866-primOpTag (VecReadByteArrayOp WordVec 64 W8) = 867-primOpTag (VecReadByteArrayOp WordVec 32 W16) = 868-primOpTag (VecReadByteArrayOp WordVec 16 W32) = 869-primOpTag (VecReadByteArrayOp WordVec 8 W64) = 870-primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 871-primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 872-primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 873-primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 874-primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 875-primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 876-primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 877-primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 878-primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 879-primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 880-primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 881-primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 882-primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 883-primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 884-primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 885-primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 886-primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 887-primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 888-primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 889-primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 890-primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 891-primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 892-primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 893-primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 894-primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 895-primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 896-primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 897-primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 898-primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 899-primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 900-primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 901-primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 902-primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 903-primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 904-primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 905-primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 906-primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 907-primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 908-primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 909-primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 910-primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 911-primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 912-primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 913-primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 914-primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 915-primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 916-primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 917-primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 918-primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 919-primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 920-primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 921-primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 922-primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 923-primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 924-primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 925-primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 926-primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 927-primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 928-primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 929-primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 930-primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 931-primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 932-primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 933-primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 934-primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 935-primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 936-primOpTag (VecReadOffAddrOp IntVec 16 W8) = 937-primOpTag (VecReadOffAddrOp IntVec 8 W16) = 938-primOpTag (VecReadOffAddrOp IntVec 4 W32) = 939-primOpTag (VecReadOffAddrOp IntVec 2 W64) = 940-primOpTag (VecReadOffAddrOp IntVec 32 W8) = 941-primOpTag (VecReadOffAddrOp IntVec 16 W16) = 942-primOpTag (VecReadOffAddrOp IntVec 8 W32) = 943-primOpTag (VecReadOffAddrOp IntVec 4 W64) = 944-primOpTag (VecReadOffAddrOp IntVec 64 W8) = 945-primOpTag (VecReadOffAddrOp IntVec 32 W16) = 946-primOpTag (VecReadOffAddrOp IntVec 16 W32) = 947-primOpTag (VecReadOffAddrOp IntVec 8 W64) = 948-primOpTag (VecReadOffAddrOp WordVec 16 W8) = 949-primOpTag (VecReadOffAddrOp WordVec 8 W16) = 950-primOpTag (VecReadOffAddrOp WordVec 4 W32) = 951-primOpTag (VecReadOffAddrOp WordVec 2 W64) = 952-primOpTag (VecReadOffAddrOp WordVec 32 W8) = 953-primOpTag (VecReadOffAddrOp WordVec 16 W16) = 954-primOpTag (VecReadOffAddrOp WordVec 8 W32) = 955-primOpTag (VecReadOffAddrOp WordVec 4 W64) = 956-primOpTag (VecReadOffAddrOp WordVec 64 W8) = 957-primOpTag (VecReadOffAddrOp WordVec 32 W16) = 958-primOpTag (VecReadOffAddrOp WordVec 16 W32) = 959-primOpTag (VecReadOffAddrOp WordVec 8 W64) = 960-primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 961-primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 962-primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 963-primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 964-primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 965-primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 966-primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 967-primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 968-primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 969-primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 970-primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 971-primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 972-primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 973-primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 974-primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 975-primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 976-primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 977-primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 978-primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 979-primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 980-primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 981-primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 982-primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 983-primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 984-primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 985-primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 986-primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 987-primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 988-primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 989-primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 990-primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 991-primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 992-primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 993-primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 994-primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 995-primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 996-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 997-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 998-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 999-primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1000-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1001-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1002-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1003-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1004-primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1005-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1006-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1007-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1008-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1009-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1010-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1011-primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1012-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1013-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1014-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1015-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1016-primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1017-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1018-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1019-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1020-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1021-primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1022-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1023-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1024-primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1025-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1026-primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1027-primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1028-primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1029-primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1030-primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1031-primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1032-primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1033-primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1034-primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1035-primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1036-primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1037-primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1038-primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1039-primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1040-primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1041-primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1042-primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1043-primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1044-primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1045-primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1046-primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1047-primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1048-primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1049-primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1050-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1051-primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1052-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1053-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1054-primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1055-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1056-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1057-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1058-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1059-primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1060-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1061-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1062-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1063-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1064-primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1065-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1066-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1067-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1068-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1069-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1070-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1071-primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1072-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1073-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1074-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1075-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1076-primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1077-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1078-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1079-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1080-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1081-primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1082-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1083-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1084-primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1085-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1086-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1087-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1088-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1089-primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1090-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1091-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1092-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1093-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1094-primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1095-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1096-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1097-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1098-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1099-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1100-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1101-primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1102-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1103-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1104-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1105-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1106-primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1107-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1108-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1109-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1110-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1111-primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1112-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1113-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1114-primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1115-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1116-primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1117-primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1118-primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1119-primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1120-primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1121-primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1122-primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1123-primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1124-primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1125-primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1126-primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1127-primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1128-primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1129-primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1130-primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1131-primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1132-primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1133-primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1134-primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1135-primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1136-primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1137-primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1138-primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1139-primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1140-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1141-primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1142-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1143-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1144-primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1145-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1146-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1147-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1148-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1149-primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1150-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1151-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1152-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1153-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1154-primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1155-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1156-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1157-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1158-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1159-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1160-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1161-primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1162-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1163-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1164-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1165-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1166-primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1167-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1168-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1169-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1170-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1171-primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1172-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1173-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1174-primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1175-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1176-primOpTag PrefetchByteArrayOp3 = 1177-primOpTag PrefetchMutableByteArrayOp3 = 1178-primOpTag PrefetchAddrOp3 = 1179-primOpTag PrefetchValueOp3 = 1180-primOpTag PrefetchByteArrayOp2 = 1181-primOpTag PrefetchMutableByteArrayOp2 = 1182-primOpTag PrefetchAddrOp2 = 1183-primOpTag PrefetchValueOp2 = 1184-primOpTag PrefetchByteArrayOp1 = 1185-primOpTag PrefetchMutableByteArrayOp1 = 1186-primOpTag PrefetchAddrOp1 = 1187-primOpTag PrefetchValueOp1 = 1188-primOpTag PrefetchByteArrayOp0 = 1189-primOpTag PrefetchMutableByteArrayOp0 = 1190-primOpTag PrefetchAddrOp0 = 1191-primOpTag PrefetchValueOp0 = 1192+maxPrimOpTag = 1203+primOpTag :: PrimOp -> Int+primOpTag CharGtOp = 1+primOpTag CharGeOp = 2+primOpTag CharEqOp = 3+primOpTag CharNeOp = 4+primOpTag CharLtOp = 5+primOpTag CharLeOp = 6+primOpTag OrdOp = 7+primOpTag IntAddOp = 8+primOpTag IntSubOp = 9+primOpTag IntMulOp = 10+primOpTag IntMulMayOfloOp = 11+primOpTag IntQuotOp = 12+primOpTag IntRemOp = 13+primOpTag IntQuotRemOp = 14+primOpTag AndIOp = 15+primOpTag OrIOp = 16+primOpTag XorIOp = 17+primOpTag NotIOp = 18+primOpTag IntNegOp = 19+primOpTag IntAddCOp = 20+primOpTag IntSubCOp = 21+primOpTag IntGtOp = 22+primOpTag IntGeOp = 23+primOpTag IntEqOp = 24+primOpTag IntNeOp = 25+primOpTag IntLtOp = 26+primOpTag IntLeOp = 27+primOpTag ChrOp = 28+primOpTag Int2WordOp = 29+primOpTag Int2FloatOp = 30+primOpTag Int2DoubleOp = 31+primOpTag Word2FloatOp = 32+primOpTag Word2DoubleOp = 33+primOpTag ISllOp = 34+primOpTag ISraOp = 35+primOpTag ISrlOp = 36+primOpTag Int8Extend = 37+primOpTag Int8Narrow = 38+primOpTag Int8NegOp = 39+primOpTag Int8AddOp = 40+primOpTag Int8SubOp = 41+primOpTag Int8MulOp = 42+primOpTag Int8QuotOp = 43+primOpTag Int8RemOp = 44+primOpTag Int8QuotRemOp = 45+primOpTag Int8EqOp = 46+primOpTag Int8GeOp = 47+primOpTag Int8GtOp = 48+primOpTag Int8LeOp = 49+primOpTag Int8LtOp = 50+primOpTag Int8NeOp = 51+primOpTag Word8Extend = 52+primOpTag Word8Narrow = 53+primOpTag Word8NotOp = 54+primOpTag Word8AddOp = 55+primOpTag Word8SubOp = 56+primOpTag Word8MulOp = 57+primOpTag Word8QuotOp = 58+primOpTag Word8RemOp = 59+primOpTag Word8QuotRemOp = 60+primOpTag Word8EqOp = 61+primOpTag Word8GeOp = 62+primOpTag Word8GtOp = 63+primOpTag Word8LeOp = 64+primOpTag Word8LtOp = 65+primOpTag Word8NeOp = 66+primOpTag Int16Extend = 67+primOpTag Int16Narrow = 68+primOpTag Int16NegOp = 69+primOpTag Int16AddOp = 70+primOpTag Int16SubOp = 71+primOpTag Int16MulOp = 72+primOpTag Int16QuotOp = 73+primOpTag Int16RemOp = 74+primOpTag Int16QuotRemOp = 75+primOpTag Int16EqOp = 76+primOpTag Int16GeOp = 77+primOpTag Int16GtOp = 78+primOpTag Int16LeOp = 79+primOpTag Int16LtOp = 80+primOpTag Int16NeOp = 81+primOpTag Word16Extend = 82+primOpTag Word16Narrow = 83+primOpTag Word16NotOp = 84+primOpTag Word16AddOp = 85+primOpTag Word16SubOp = 86+primOpTag Word16MulOp = 87+primOpTag Word16QuotOp = 88+primOpTag Word16RemOp = 89+primOpTag Word16QuotRemOp = 90+primOpTag Word16EqOp = 91+primOpTag Word16GeOp = 92+primOpTag Word16GtOp = 93+primOpTag Word16LeOp = 94+primOpTag Word16LtOp = 95+primOpTag Word16NeOp = 96+primOpTag WordAddOp = 97+primOpTag WordAddCOp = 98+primOpTag WordSubCOp = 99+primOpTag WordAdd2Op = 100+primOpTag WordSubOp = 101+primOpTag WordMulOp = 102+primOpTag WordMul2Op = 103+primOpTag WordQuotOp = 104+primOpTag WordRemOp = 105+primOpTag WordQuotRemOp = 106+primOpTag WordQuotRem2Op = 107+primOpTag AndOp = 108+primOpTag OrOp = 109+primOpTag XorOp = 110+primOpTag NotOp = 111+primOpTag SllOp = 112+primOpTag SrlOp = 113+primOpTag Word2IntOp = 114+primOpTag WordGtOp = 115+primOpTag WordGeOp = 116+primOpTag WordEqOp = 117+primOpTag WordNeOp = 118+primOpTag WordLtOp = 119+primOpTag WordLeOp = 120+primOpTag PopCnt8Op = 121+primOpTag PopCnt16Op = 122+primOpTag PopCnt32Op = 123+primOpTag PopCnt64Op = 124+primOpTag PopCntOp = 125+primOpTag Pdep8Op = 126+primOpTag Pdep16Op = 127+primOpTag Pdep32Op = 128+primOpTag Pdep64Op = 129+primOpTag PdepOp = 130+primOpTag Pext8Op = 131+primOpTag Pext16Op = 132+primOpTag Pext32Op = 133+primOpTag Pext64Op = 134+primOpTag PextOp = 135+primOpTag Clz8Op = 136+primOpTag Clz16Op = 137+primOpTag Clz32Op = 138+primOpTag Clz64Op = 139+primOpTag ClzOp = 140+primOpTag Ctz8Op = 141+primOpTag Ctz16Op = 142+primOpTag Ctz32Op = 143+primOpTag Ctz64Op = 144+primOpTag CtzOp = 145+primOpTag BSwap16Op = 146+primOpTag BSwap32Op = 147+primOpTag BSwap64Op = 148+primOpTag BSwapOp = 149+primOpTag BRev8Op = 150+primOpTag BRev16Op = 151+primOpTag BRev32Op = 152+primOpTag BRev64Op = 153+primOpTag BRevOp = 154+primOpTag Narrow8IntOp = 155+primOpTag Narrow16IntOp = 156+primOpTag Narrow32IntOp = 157+primOpTag Narrow8WordOp = 158+primOpTag Narrow16WordOp = 159+primOpTag Narrow32WordOp = 160+primOpTag DoubleGtOp = 161+primOpTag DoubleGeOp = 162+primOpTag DoubleEqOp = 163+primOpTag DoubleNeOp = 164+primOpTag DoubleLtOp = 165+primOpTag DoubleLeOp = 166+primOpTag DoubleAddOp = 167+primOpTag DoubleSubOp = 168+primOpTag DoubleMulOp = 169+primOpTag DoubleDivOp = 170+primOpTag DoubleNegOp = 171+primOpTag DoubleFabsOp = 172+primOpTag Double2IntOp = 173+primOpTag Double2FloatOp = 174+primOpTag DoubleExpOp = 175+primOpTag DoubleExpM1Op = 176+primOpTag DoubleLogOp = 177+primOpTag DoubleLog1POp = 178+primOpTag DoubleSqrtOp = 179+primOpTag DoubleSinOp = 180+primOpTag DoubleCosOp = 181+primOpTag DoubleTanOp = 182+primOpTag DoubleAsinOp = 183+primOpTag DoubleAcosOp = 184+primOpTag DoubleAtanOp = 185+primOpTag DoubleSinhOp = 186+primOpTag DoubleCoshOp = 187+primOpTag DoubleTanhOp = 188+primOpTag DoubleAsinhOp = 189+primOpTag DoubleAcoshOp = 190+primOpTag DoubleAtanhOp = 191+primOpTag DoublePowerOp = 192+primOpTag DoubleDecode_2IntOp = 193+primOpTag DoubleDecode_Int64Op = 194+primOpTag FloatGtOp = 195+primOpTag FloatGeOp = 196+primOpTag FloatEqOp = 197+primOpTag FloatNeOp = 198+primOpTag FloatLtOp = 199+primOpTag FloatLeOp = 200+primOpTag FloatAddOp = 201+primOpTag FloatSubOp = 202+primOpTag FloatMulOp = 203+primOpTag FloatDivOp = 204+primOpTag FloatNegOp = 205+primOpTag FloatFabsOp = 206+primOpTag Float2IntOp = 207+primOpTag FloatExpOp = 208+primOpTag FloatExpM1Op = 209+primOpTag FloatLogOp = 210+primOpTag FloatLog1POp = 211+primOpTag FloatSqrtOp = 212+primOpTag FloatSinOp = 213+primOpTag FloatCosOp = 214+primOpTag FloatTanOp = 215+primOpTag FloatAsinOp = 216+primOpTag FloatAcosOp = 217+primOpTag FloatAtanOp = 218+primOpTag FloatSinhOp = 219+primOpTag FloatCoshOp = 220+primOpTag FloatTanhOp = 221+primOpTag FloatAsinhOp = 222+primOpTag FloatAcoshOp = 223+primOpTag FloatAtanhOp = 224+primOpTag FloatPowerOp = 225+primOpTag Float2DoubleOp = 226+primOpTag FloatDecode_IntOp = 227+primOpTag NewArrayOp = 228+primOpTag SameMutableArrayOp = 229+primOpTag ReadArrayOp = 230+primOpTag WriteArrayOp = 231+primOpTag SizeofArrayOp = 232+primOpTag SizeofMutableArrayOp = 233+primOpTag IndexArrayOp = 234+primOpTag UnsafeFreezeArrayOp = 235+primOpTag UnsafeThawArrayOp = 236+primOpTag CopyArrayOp = 237+primOpTag CopyMutableArrayOp = 238+primOpTag CloneArrayOp = 239+primOpTag CloneMutableArrayOp = 240+primOpTag FreezeArrayOp = 241+primOpTag ThawArrayOp = 242+primOpTag CasArrayOp = 243+primOpTag NewSmallArrayOp = 244+primOpTag SameSmallMutableArrayOp = 245+primOpTag ShrinkSmallMutableArrayOp_Char = 246+primOpTag ReadSmallArrayOp = 247+primOpTag WriteSmallArrayOp = 248+primOpTag SizeofSmallArrayOp = 249+primOpTag SizeofSmallMutableArrayOp = 250+primOpTag GetSizeofSmallMutableArrayOp = 251+primOpTag IndexSmallArrayOp = 252+primOpTag UnsafeFreezeSmallArrayOp = 253+primOpTag UnsafeThawSmallArrayOp = 254+primOpTag CopySmallArrayOp = 255+primOpTag CopySmallMutableArrayOp = 256+primOpTag CloneSmallArrayOp = 257+primOpTag CloneSmallMutableArrayOp = 258+primOpTag FreezeSmallArrayOp = 259+primOpTag ThawSmallArrayOp = 260+primOpTag CasSmallArrayOp = 261+primOpTag NewByteArrayOp_Char = 262+primOpTag NewPinnedByteArrayOp_Char = 263+primOpTag NewAlignedPinnedByteArrayOp_Char = 264+primOpTag MutableByteArrayIsPinnedOp = 265+primOpTag ByteArrayIsPinnedOp = 266+primOpTag ByteArrayContents_Char = 267+primOpTag SameMutableByteArrayOp = 268+primOpTag ShrinkMutableByteArrayOp_Char = 269+primOpTag ResizeMutableByteArrayOp_Char = 270+primOpTag UnsafeFreezeByteArrayOp = 271+primOpTag SizeofByteArrayOp = 272+primOpTag SizeofMutableByteArrayOp = 273+primOpTag GetSizeofMutableByteArrayOp = 274+primOpTag IndexByteArrayOp_Char = 275+primOpTag IndexByteArrayOp_WideChar = 276+primOpTag IndexByteArrayOp_Int = 277+primOpTag IndexByteArrayOp_Word = 278+primOpTag IndexByteArrayOp_Addr = 279+primOpTag IndexByteArrayOp_Float = 280+primOpTag IndexByteArrayOp_Double = 281+primOpTag IndexByteArrayOp_StablePtr = 282+primOpTag IndexByteArrayOp_Int8 = 283+primOpTag IndexByteArrayOp_Int16 = 284+primOpTag IndexByteArrayOp_Int32 = 285+primOpTag IndexByteArrayOp_Int64 = 286+primOpTag IndexByteArrayOp_Word8 = 287+primOpTag IndexByteArrayOp_Word16 = 288+primOpTag IndexByteArrayOp_Word32 = 289+primOpTag IndexByteArrayOp_Word64 = 290+primOpTag IndexByteArrayOp_Word8AsChar = 291+primOpTag IndexByteArrayOp_Word8AsWideChar = 292+primOpTag IndexByteArrayOp_Word8AsAddr = 293+primOpTag IndexByteArrayOp_Word8AsFloat = 294+primOpTag IndexByteArrayOp_Word8AsDouble = 295+primOpTag IndexByteArrayOp_Word8AsStablePtr = 296+primOpTag IndexByteArrayOp_Word8AsInt16 = 297+primOpTag IndexByteArrayOp_Word8AsInt32 = 298+primOpTag IndexByteArrayOp_Word8AsInt64 = 299+primOpTag IndexByteArrayOp_Word8AsInt = 300+primOpTag IndexByteArrayOp_Word8AsWord16 = 301+primOpTag IndexByteArrayOp_Word8AsWord32 = 302+primOpTag IndexByteArrayOp_Word8AsWord64 = 303+primOpTag IndexByteArrayOp_Word8AsWord = 304+primOpTag ReadByteArrayOp_Char = 305+primOpTag ReadByteArrayOp_WideChar = 306+primOpTag ReadByteArrayOp_Int = 307+primOpTag ReadByteArrayOp_Word = 308+primOpTag ReadByteArrayOp_Addr = 309+primOpTag ReadByteArrayOp_Float = 310+primOpTag ReadByteArrayOp_Double = 311+primOpTag ReadByteArrayOp_StablePtr = 312+primOpTag ReadByteArrayOp_Int8 = 313+primOpTag ReadByteArrayOp_Int16 = 314+primOpTag ReadByteArrayOp_Int32 = 315+primOpTag ReadByteArrayOp_Int64 = 316+primOpTag ReadByteArrayOp_Word8 = 317+primOpTag ReadByteArrayOp_Word16 = 318+primOpTag ReadByteArrayOp_Word32 = 319+primOpTag ReadByteArrayOp_Word64 = 320+primOpTag ReadByteArrayOp_Word8AsChar = 321+primOpTag ReadByteArrayOp_Word8AsWideChar = 322+primOpTag ReadByteArrayOp_Word8AsAddr = 323+primOpTag ReadByteArrayOp_Word8AsFloat = 324+primOpTag ReadByteArrayOp_Word8AsDouble = 325+primOpTag ReadByteArrayOp_Word8AsStablePtr = 326+primOpTag ReadByteArrayOp_Word8AsInt16 = 327+primOpTag ReadByteArrayOp_Word8AsInt32 = 328+primOpTag ReadByteArrayOp_Word8AsInt64 = 329+primOpTag ReadByteArrayOp_Word8AsInt = 330+primOpTag ReadByteArrayOp_Word8AsWord16 = 331+primOpTag ReadByteArrayOp_Word8AsWord32 = 332+primOpTag ReadByteArrayOp_Word8AsWord64 = 333+primOpTag ReadByteArrayOp_Word8AsWord = 334+primOpTag WriteByteArrayOp_Char = 335+primOpTag WriteByteArrayOp_WideChar = 336+primOpTag WriteByteArrayOp_Int = 337+primOpTag WriteByteArrayOp_Word = 338+primOpTag WriteByteArrayOp_Addr = 339+primOpTag WriteByteArrayOp_Float = 340+primOpTag WriteByteArrayOp_Double = 341+primOpTag WriteByteArrayOp_StablePtr = 342+primOpTag WriteByteArrayOp_Int8 = 343+primOpTag WriteByteArrayOp_Int16 = 344+primOpTag WriteByteArrayOp_Int32 = 345+primOpTag WriteByteArrayOp_Int64 = 346+primOpTag WriteByteArrayOp_Word8 = 347+primOpTag WriteByteArrayOp_Word16 = 348+primOpTag WriteByteArrayOp_Word32 = 349+primOpTag WriteByteArrayOp_Word64 = 350+primOpTag WriteByteArrayOp_Word8AsChar = 351+primOpTag WriteByteArrayOp_Word8AsWideChar = 352+primOpTag WriteByteArrayOp_Word8AsAddr = 353+primOpTag WriteByteArrayOp_Word8AsFloat = 354+primOpTag WriteByteArrayOp_Word8AsDouble = 355+primOpTag WriteByteArrayOp_Word8AsStablePtr = 356+primOpTag WriteByteArrayOp_Word8AsInt16 = 357+primOpTag WriteByteArrayOp_Word8AsInt32 = 358+primOpTag WriteByteArrayOp_Word8AsInt64 = 359+primOpTag WriteByteArrayOp_Word8AsInt = 360+primOpTag WriteByteArrayOp_Word8AsWord16 = 361+primOpTag WriteByteArrayOp_Word8AsWord32 = 362+primOpTag WriteByteArrayOp_Word8AsWord64 = 363+primOpTag WriteByteArrayOp_Word8AsWord = 364+primOpTag CompareByteArraysOp = 365+primOpTag CopyByteArrayOp = 366+primOpTag CopyMutableByteArrayOp = 367+primOpTag CopyByteArrayToAddrOp = 368+primOpTag CopyMutableByteArrayToAddrOp = 369+primOpTag CopyAddrToByteArrayOp = 370+primOpTag SetByteArrayOp = 371+primOpTag AtomicReadByteArrayOp_Int = 372+primOpTag AtomicWriteByteArrayOp_Int = 373+primOpTag CasByteArrayOp_Int = 374+primOpTag FetchAddByteArrayOp_Int = 375+primOpTag FetchSubByteArrayOp_Int = 376+primOpTag FetchAndByteArrayOp_Int = 377+primOpTag FetchNandByteArrayOp_Int = 378+primOpTag FetchOrByteArrayOp_Int = 379+primOpTag FetchXorByteArrayOp_Int = 380+primOpTag NewArrayArrayOp = 381+primOpTag SameMutableArrayArrayOp = 382+primOpTag UnsafeFreezeArrayArrayOp = 383+primOpTag SizeofArrayArrayOp = 384+primOpTag SizeofMutableArrayArrayOp = 385+primOpTag IndexArrayArrayOp_ByteArray = 386+primOpTag IndexArrayArrayOp_ArrayArray = 387+primOpTag ReadArrayArrayOp_ByteArray = 388+primOpTag ReadArrayArrayOp_MutableByteArray = 389+primOpTag ReadArrayArrayOp_ArrayArray = 390+primOpTag ReadArrayArrayOp_MutableArrayArray = 391+primOpTag WriteArrayArrayOp_ByteArray = 392+primOpTag WriteArrayArrayOp_MutableByteArray = 393+primOpTag WriteArrayArrayOp_ArrayArray = 394+primOpTag WriteArrayArrayOp_MutableArrayArray = 395+primOpTag CopyArrayArrayOp = 396+primOpTag CopyMutableArrayArrayOp = 397+primOpTag AddrAddOp = 398+primOpTag AddrSubOp = 399+primOpTag AddrRemOp = 400+primOpTag Addr2IntOp = 401+primOpTag Int2AddrOp = 402+primOpTag AddrGtOp = 403+primOpTag AddrGeOp = 404+primOpTag AddrEqOp = 405+primOpTag AddrNeOp = 406+primOpTag AddrLtOp = 407+primOpTag AddrLeOp = 408+primOpTag IndexOffAddrOp_Char = 409+primOpTag IndexOffAddrOp_WideChar = 410+primOpTag IndexOffAddrOp_Int = 411+primOpTag IndexOffAddrOp_Word = 412+primOpTag IndexOffAddrOp_Addr = 413+primOpTag IndexOffAddrOp_Float = 414+primOpTag IndexOffAddrOp_Double = 415+primOpTag IndexOffAddrOp_StablePtr = 416+primOpTag IndexOffAddrOp_Int8 = 417+primOpTag IndexOffAddrOp_Int16 = 418+primOpTag IndexOffAddrOp_Int32 = 419+primOpTag IndexOffAddrOp_Int64 = 420+primOpTag IndexOffAddrOp_Word8 = 421+primOpTag IndexOffAddrOp_Word16 = 422+primOpTag IndexOffAddrOp_Word32 = 423+primOpTag IndexOffAddrOp_Word64 = 424+primOpTag ReadOffAddrOp_Char = 425+primOpTag ReadOffAddrOp_WideChar = 426+primOpTag ReadOffAddrOp_Int = 427+primOpTag ReadOffAddrOp_Word = 428+primOpTag ReadOffAddrOp_Addr = 429+primOpTag ReadOffAddrOp_Float = 430+primOpTag ReadOffAddrOp_Double = 431+primOpTag ReadOffAddrOp_StablePtr = 432+primOpTag ReadOffAddrOp_Int8 = 433+primOpTag ReadOffAddrOp_Int16 = 434+primOpTag ReadOffAddrOp_Int32 = 435+primOpTag ReadOffAddrOp_Int64 = 436+primOpTag ReadOffAddrOp_Word8 = 437+primOpTag ReadOffAddrOp_Word16 = 438+primOpTag ReadOffAddrOp_Word32 = 439+primOpTag ReadOffAddrOp_Word64 = 440+primOpTag WriteOffAddrOp_Char = 441+primOpTag WriteOffAddrOp_WideChar = 442+primOpTag WriteOffAddrOp_Int = 443+primOpTag WriteOffAddrOp_Word = 444+primOpTag WriteOffAddrOp_Addr = 445+primOpTag WriteOffAddrOp_Float = 446+primOpTag WriteOffAddrOp_Double = 447+primOpTag WriteOffAddrOp_StablePtr = 448+primOpTag WriteOffAddrOp_Int8 = 449+primOpTag WriteOffAddrOp_Int16 = 450+primOpTag WriteOffAddrOp_Int32 = 451+primOpTag WriteOffAddrOp_Int64 = 452+primOpTag WriteOffAddrOp_Word8 = 453+primOpTag WriteOffAddrOp_Word16 = 454+primOpTag WriteOffAddrOp_Word32 = 455+primOpTag WriteOffAddrOp_Word64 = 456+primOpTag NewMutVarOp = 457+primOpTag ReadMutVarOp = 458+primOpTag WriteMutVarOp = 459+primOpTag SameMutVarOp = 460+primOpTag AtomicModifyMutVar2Op = 461+primOpTag AtomicModifyMutVar_Op = 462+primOpTag CasMutVarOp = 463+primOpTag CatchOp = 464+primOpTag RaiseOp = 465+primOpTag RaiseIOOp = 466+primOpTag MaskAsyncExceptionsOp = 467+primOpTag MaskUninterruptibleOp = 468+primOpTag UnmaskAsyncExceptionsOp = 469+primOpTag MaskStatus = 470+primOpTag AtomicallyOp = 471+primOpTag RetryOp = 472+primOpTag CatchRetryOp = 473+primOpTag CatchSTMOp = 474+primOpTag NewTVarOp = 475+primOpTag ReadTVarOp = 476+primOpTag ReadTVarIOOp = 477+primOpTag WriteTVarOp = 478+primOpTag SameTVarOp = 479+primOpTag NewMVarOp = 480+primOpTag TakeMVarOp = 481+primOpTag TryTakeMVarOp = 482+primOpTag PutMVarOp = 483+primOpTag TryPutMVarOp = 484+primOpTag ReadMVarOp = 485+primOpTag TryReadMVarOp = 486+primOpTag SameMVarOp = 487+primOpTag IsEmptyMVarOp = 488+primOpTag DelayOp = 489+primOpTag WaitReadOp = 490+primOpTag WaitWriteOp = 491+primOpTag ForkOp = 492+primOpTag ForkOnOp = 493+primOpTag KillThreadOp = 494+primOpTag YieldOp = 495+primOpTag MyThreadIdOp = 496+primOpTag LabelThreadOp = 497+primOpTag IsCurrentThreadBoundOp = 498+primOpTag NoDuplicateOp = 499+primOpTag ThreadStatusOp = 500+primOpTag MkWeakOp = 501+primOpTag MkWeakNoFinalizerOp = 502+primOpTag AddCFinalizerToWeakOp = 503+primOpTag DeRefWeakOp = 504+primOpTag FinalizeWeakOp = 505+primOpTag TouchOp = 506+primOpTag MakeStablePtrOp = 507+primOpTag DeRefStablePtrOp = 508+primOpTag EqStablePtrOp = 509+primOpTag MakeStableNameOp = 510+primOpTag EqStableNameOp = 511+primOpTag StableNameToIntOp = 512+primOpTag CompactNewOp = 513+primOpTag CompactResizeOp = 514+primOpTag CompactContainsOp = 515+primOpTag CompactContainsAnyOp = 516+primOpTag CompactGetFirstBlockOp = 517+primOpTag CompactGetNextBlockOp = 518+primOpTag CompactAllocateBlockOp = 519+primOpTag CompactFixupPointersOp = 520+primOpTag CompactAdd = 521+primOpTag CompactAddWithSharing = 522+primOpTag CompactSize = 523+primOpTag ReallyUnsafePtrEqualityOp = 524+primOpTag ParOp = 525+primOpTag SparkOp = 526+primOpTag SeqOp = 527+primOpTag GetSparkOp = 528+primOpTag NumSparks = 529+primOpTag DataToTagOp = 530+primOpTag TagToEnumOp = 531+primOpTag AddrToAnyOp = 532+primOpTag AnyToAddrOp = 533+primOpTag MkApUpd0_Op = 534+primOpTag NewBCOOp = 535+primOpTag UnpackClosureOp = 536+primOpTag ClosureSizeOp = 537+primOpTag GetApStackValOp = 538+primOpTag GetCCSOfOp = 539+primOpTag GetCurrentCCSOp = 540+primOpTag ClearCCSOp = 541+primOpTag TraceEventOp = 542+primOpTag TraceEventBinaryOp = 543+primOpTag TraceMarkerOp = 544+primOpTag SetThreadAllocationCounter = 545+primOpTag (VecBroadcastOp IntVec 16 W8) = 546+primOpTag (VecBroadcastOp IntVec 8 W16) = 547+primOpTag (VecBroadcastOp IntVec 4 W32) = 548+primOpTag (VecBroadcastOp IntVec 2 W64) = 549+primOpTag (VecBroadcastOp IntVec 32 W8) = 550+primOpTag (VecBroadcastOp IntVec 16 W16) = 551+primOpTag (VecBroadcastOp IntVec 8 W32) = 552+primOpTag (VecBroadcastOp IntVec 4 W64) = 553+primOpTag (VecBroadcastOp IntVec 64 W8) = 554+primOpTag (VecBroadcastOp IntVec 32 W16) = 555+primOpTag (VecBroadcastOp IntVec 16 W32) = 556+primOpTag (VecBroadcastOp IntVec 8 W64) = 557+primOpTag (VecBroadcastOp WordVec 16 W8) = 558+primOpTag (VecBroadcastOp WordVec 8 W16) = 559+primOpTag (VecBroadcastOp WordVec 4 W32) = 560+primOpTag (VecBroadcastOp WordVec 2 W64) = 561+primOpTag (VecBroadcastOp WordVec 32 W8) = 562+primOpTag (VecBroadcastOp WordVec 16 W16) = 563+primOpTag (VecBroadcastOp WordVec 8 W32) = 564+primOpTag (VecBroadcastOp WordVec 4 W64) = 565+primOpTag (VecBroadcastOp WordVec 64 W8) = 566+primOpTag (VecBroadcastOp WordVec 32 W16) = 567+primOpTag (VecBroadcastOp WordVec 16 W32) = 568+primOpTag (VecBroadcastOp WordVec 8 W64) = 569+primOpTag (VecBroadcastOp FloatVec 4 W32) = 570+primOpTag (VecBroadcastOp FloatVec 2 W64) = 571+primOpTag (VecBroadcastOp FloatVec 8 W32) = 572+primOpTag (VecBroadcastOp FloatVec 4 W64) = 573+primOpTag (VecBroadcastOp FloatVec 16 W32) = 574+primOpTag (VecBroadcastOp FloatVec 8 W64) = 575+primOpTag (VecPackOp IntVec 16 W8) = 576+primOpTag (VecPackOp IntVec 8 W16) = 577+primOpTag (VecPackOp IntVec 4 W32) = 578+primOpTag (VecPackOp IntVec 2 W64) = 579+primOpTag (VecPackOp IntVec 32 W8) = 580+primOpTag (VecPackOp IntVec 16 W16) = 581+primOpTag (VecPackOp IntVec 8 W32) = 582+primOpTag (VecPackOp IntVec 4 W64) = 583+primOpTag (VecPackOp IntVec 64 W8) = 584+primOpTag (VecPackOp IntVec 32 W16) = 585+primOpTag (VecPackOp IntVec 16 W32) = 586+primOpTag (VecPackOp IntVec 8 W64) = 587+primOpTag (VecPackOp WordVec 16 W8) = 588+primOpTag (VecPackOp WordVec 8 W16) = 589+primOpTag (VecPackOp WordVec 4 W32) = 590+primOpTag (VecPackOp WordVec 2 W64) = 591+primOpTag (VecPackOp WordVec 32 W8) = 592+primOpTag (VecPackOp WordVec 16 W16) = 593+primOpTag (VecPackOp WordVec 8 W32) = 594+primOpTag (VecPackOp WordVec 4 W64) = 595+primOpTag (VecPackOp WordVec 64 W8) = 596+primOpTag (VecPackOp WordVec 32 W16) = 597+primOpTag (VecPackOp WordVec 16 W32) = 598+primOpTag (VecPackOp WordVec 8 W64) = 599+primOpTag (VecPackOp FloatVec 4 W32) = 600+primOpTag (VecPackOp FloatVec 2 W64) = 601+primOpTag (VecPackOp FloatVec 8 W32) = 602+primOpTag (VecPackOp FloatVec 4 W64) = 603+primOpTag (VecPackOp FloatVec 16 W32) = 604+primOpTag (VecPackOp FloatVec 8 W64) = 605+primOpTag (VecUnpackOp IntVec 16 W8) = 606+primOpTag (VecUnpackOp IntVec 8 W16) = 607+primOpTag (VecUnpackOp IntVec 4 W32) = 608+primOpTag (VecUnpackOp IntVec 2 W64) = 609+primOpTag (VecUnpackOp IntVec 32 W8) = 610+primOpTag (VecUnpackOp IntVec 16 W16) = 611+primOpTag (VecUnpackOp IntVec 8 W32) = 612+primOpTag (VecUnpackOp IntVec 4 W64) = 613+primOpTag (VecUnpackOp IntVec 64 W8) = 614+primOpTag (VecUnpackOp IntVec 32 W16) = 615+primOpTag (VecUnpackOp IntVec 16 W32) = 616+primOpTag (VecUnpackOp IntVec 8 W64) = 617+primOpTag (VecUnpackOp WordVec 16 W8) = 618+primOpTag (VecUnpackOp WordVec 8 W16) = 619+primOpTag (VecUnpackOp WordVec 4 W32) = 620+primOpTag (VecUnpackOp WordVec 2 W64) = 621+primOpTag (VecUnpackOp WordVec 32 W8) = 622+primOpTag (VecUnpackOp WordVec 16 W16) = 623+primOpTag (VecUnpackOp WordVec 8 W32) = 624+primOpTag (VecUnpackOp WordVec 4 W64) = 625+primOpTag (VecUnpackOp WordVec 64 W8) = 626+primOpTag (VecUnpackOp WordVec 32 W16) = 627+primOpTag (VecUnpackOp WordVec 16 W32) = 628+primOpTag (VecUnpackOp WordVec 8 W64) = 629+primOpTag (VecUnpackOp FloatVec 4 W32) = 630+primOpTag (VecUnpackOp FloatVec 2 W64) = 631+primOpTag (VecUnpackOp FloatVec 8 W32) = 632+primOpTag (VecUnpackOp FloatVec 4 W64) = 633+primOpTag (VecUnpackOp FloatVec 16 W32) = 634+primOpTag (VecUnpackOp FloatVec 8 W64) = 635+primOpTag (VecInsertOp IntVec 16 W8) = 636+primOpTag (VecInsertOp IntVec 8 W16) = 637+primOpTag (VecInsertOp IntVec 4 W32) = 638+primOpTag (VecInsertOp IntVec 2 W64) = 639+primOpTag (VecInsertOp IntVec 32 W8) = 640+primOpTag (VecInsertOp IntVec 16 W16) = 641+primOpTag (VecInsertOp IntVec 8 W32) = 642+primOpTag (VecInsertOp IntVec 4 W64) = 643+primOpTag (VecInsertOp IntVec 64 W8) = 644+primOpTag (VecInsertOp IntVec 32 W16) = 645+primOpTag (VecInsertOp IntVec 16 W32) = 646+primOpTag (VecInsertOp IntVec 8 W64) = 647+primOpTag (VecInsertOp WordVec 16 W8) = 648+primOpTag (VecInsertOp WordVec 8 W16) = 649+primOpTag (VecInsertOp WordVec 4 W32) = 650+primOpTag (VecInsertOp WordVec 2 W64) = 651+primOpTag (VecInsertOp WordVec 32 W8) = 652+primOpTag (VecInsertOp WordVec 16 W16) = 653+primOpTag (VecInsertOp WordVec 8 W32) = 654+primOpTag (VecInsertOp WordVec 4 W64) = 655+primOpTag (VecInsertOp WordVec 64 W8) = 656+primOpTag (VecInsertOp WordVec 32 W16) = 657+primOpTag (VecInsertOp WordVec 16 W32) = 658+primOpTag (VecInsertOp WordVec 8 W64) = 659+primOpTag (VecInsertOp FloatVec 4 W32) = 660+primOpTag (VecInsertOp FloatVec 2 W64) = 661+primOpTag (VecInsertOp FloatVec 8 W32) = 662+primOpTag (VecInsertOp FloatVec 4 W64) = 663+primOpTag (VecInsertOp FloatVec 16 W32) = 664+primOpTag (VecInsertOp FloatVec 8 W64) = 665+primOpTag (VecAddOp IntVec 16 W8) = 666+primOpTag (VecAddOp IntVec 8 W16) = 667+primOpTag (VecAddOp IntVec 4 W32) = 668+primOpTag (VecAddOp IntVec 2 W64) = 669+primOpTag (VecAddOp IntVec 32 W8) = 670+primOpTag (VecAddOp IntVec 16 W16) = 671+primOpTag (VecAddOp IntVec 8 W32) = 672+primOpTag (VecAddOp IntVec 4 W64) = 673+primOpTag (VecAddOp IntVec 64 W8) = 674+primOpTag (VecAddOp IntVec 32 W16) = 675+primOpTag (VecAddOp IntVec 16 W32) = 676+primOpTag (VecAddOp IntVec 8 W64) = 677+primOpTag (VecAddOp WordVec 16 W8) = 678+primOpTag (VecAddOp WordVec 8 W16) = 679+primOpTag (VecAddOp WordVec 4 W32) = 680+primOpTag (VecAddOp WordVec 2 W64) = 681+primOpTag (VecAddOp WordVec 32 W8) = 682+primOpTag (VecAddOp WordVec 16 W16) = 683+primOpTag (VecAddOp WordVec 8 W32) = 684+primOpTag (VecAddOp WordVec 4 W64) = 685+primOpTag (VecAddOp WordVec 64 W8) = 686+primOpTag (VecAddOp WordVec 32 W16) = 687+primOpTag (VecAddOp WordVec 16 W32) = 688+primOpTag (VecAddOp WordVec 8 W64) = 689+primOpTag (VecAddOp FloatVec 4 W32) = 690+primOpTag (VecAddOp FloatVec 2 W64) = 691+primOpTag (VecAddOp FloatVec 8 W32) = 692+primOpTag (VecAddOp FloatVec 4 W64) = 693+primOpTag (VecAddOp FloatVec 16 W32) = 694+primOpTag (VecAddOp FloatVec 8 W64) = 695+primOpTag (VecSubOp IntVec 16 W8) = 696+primOpTag (VecSubOp IntVec 8 W16) = 697+primOpTag (VecSubOp IntVec 4 W32) = 698+primOpTag (VecSubOp IntVec 2 W64) = 699+primOpTag (VecSubOp IntVec 32 W8) = 700+primOpTag (VecSubOp IntVec 16 W16) = 701+primOpTag (VecSubOp IntVec 8 W32) = 702+primOpTag (VecSubOp IntVec 4 W64) = 703+primOpTag (VecSubOp IntVec 64 W8) = 704+primOpTag (VecSubOp IntVec 32 W16) = 705+primOpTag (VecSubOp IntVec 16 W32) = 706+primOpTag (VecSubOp IntVec 8 W64) = 707+primOpTag (VecSubOp WordVec 16 W8) = 708+primOpTag (VecSubOp WordVec 8 W16) = 709+primOpTag (VecSubOp WordVec 4 W32) = 710+primOpTag (VecSubOp WordVec 2 W64) = 711+primOpTag (VecSubOp WordVec 32 W8) = 712+primOpTag (VecSubOp WordVec 16 W16) = 713+primOpTag (VecSubOp WordVec 8 W32) = 714+primOpTag (VecSubOp WordVec 4 W64) = 715+primOpTag (VecSubOp WordVec 64 W8) = 716+primOpTag (VecSubOp WordVec 32 W16) = 717+primOpTag (VecSubOp WordVec 16 W32) = 718+primOpTag (VecSubOp WordVec 8 W64) = 719+primOpTag (VecSubOp FloatVec 4 W32) = 720+primOpTag (VecSubOp FloatVec 2 W64) = 721+primOpTag (VecSubOp FloatVec 8 W32) = 722+primOpTag (VecSubOp FloatVec 4 W64) = 723+primOpTag (VecSubOp FloatVec 16 W32) = 724+primOpTag (VecSubOp FloatVec 8 W64) = 725+primOpTag (VecMulOp IntVec 16 W8) = 726+primOpTag (VecMulOp IntVec 8 W16) = 727+primOpTag (VecMulOp IntVec 4 W32) = 728+primOpTag (VecMulOp IntVec 2 W64) = 729+primOpTag (VecMulOp IntVec 32 W8) = 730+primOpTag (VecMulOp IntVec 16 W16) = 731+primOpTag (VecMulOp IntVec 8 W32) = 732+primOpTag (VecMulOp IntVec 4 W64) = 733+primOpTag (VecMulOp IntVec 64 W8) = 734+primOpTag (VecMulOp IntVec 32 W16) = 735+primOpTag (VecMulOp IntVec 16 W32) = 736+primOpTag (VecMulOp IntVec 8 W64) = 737+primOpTag (VecMulOp WordVec 16 W8) = 738+primOpTag (VecMulOp WordVec 8 W16) = 739+primOpTag (VecMulOp WordVec 4 W32) = 740+primOpTag (VecMulOp WordVec 2 W64) = 741+primOpTag (VecMulOp WordVec 32 W8) = 742+primOpTag (VecMulOp WordVec 16 W16) = 743+primOpTag (VecMulOp WordVec 8 W32) = 744+primOpTag (VecMulOp WordVec 4 W64) = 745+primOpTag (VecMulOp WordVec 64 W8) = 746+primOpTag (VecMulOp WordVec 32 W16) = 747+primOpTag (VecMulOp WordVec 16 W32) = 748+primOpTag (VecMulOp WordVec 8 W64) = 749+primOpTag (VecMulOp FloatVec 4 W32) = 750+primOpTag (VecMulOp FloatVec 2 W64) = 751+primOpTag (VecMulOp FloatVec 8 W32) = 752+primOpTag (VecMulOp FloatVec 4 W64) = 753+primOpTag (VecMulOp FloatVec 16 W32) = 754+primOpTag (VecMulOp FloatVec 8 W64) = 755+primOpTag (VecDivOp FloatVec 4 W32) = 756+primOpTag (VecDivOp FloatVec 2 W64) = 757+primOpTag (VecDivOp FloatVec 8 W32) = 758+primOpTag (VecDivOp FloatVec 4 W64) = 759+primOpTag (VecDivOp FloatVec 16 W32) = 760+primOpTag (VecDivOp FloatVec 8 W64) = 761+primOpTag (VecQuotOp IntVec 16 W8) = 762+primOpTag (VecQuotOp IntVec 8 W16) = 763+primOpTag (VecQuotOp IntVec 4 W32) = 764+primOpTag (VecQuotOp IntVec 2 W64) = 765+primOpTag (VecQuotOp IntVec 32 W8) = 766+primOpTag (VecQuotOp IntVec 16 W16) = 767+primOpTag (VecQuotOp IntVec 8 W32) = 768+primOpTag (VecQuotOp IntVec 4 W64) = 769+primOpTag (VecQuotOp IntVec 64 W8) = 770+primOpTag (VecQuotOp IntVec 32 W16) = 771+primOpTag (VecQuotOp IntVec 16 W32) = 772+primOpTag (VecQuotOp IntVec 8 W64) = 773+primOpTag (VecQuotOp WordVec 16 W8) = 774+primOpTag (VecQuotOp WordVec 8 W16) = 775+primOpTag (VecQuotOp WordVec 4 W32) = 776+primOpTag (VecQuotOp WordVec 2 W64) = 777+primOpTag (VecQuotOp WordVec 32 W8) = 778+primOpTag (VecQuotOp WordVec 16 W16) = 779+primOpTag (VecQuotOp WordVec 8 W32) = 780+primOpTag (VecQuotOp WordVec 4 W64) = 781+primOpTag (VecQuotOp WordVec 64 W8) = 782+primOpTag (VecQuotOp WordVec 32 W16) = 783+primOpTag (VecQuotOp WordVec 16 W32) = 784+primOpTag (VecQuotOp WordVec 8 W64) = 785+primOpTag (VecRemOp IntVec 16 W8) = 786+primOpTag (VecRemOp IntVec 8 W16) = 787+primOpTag (VecRemOp IntVec 4 W32) = 788+primOpTag (VecRemOp IntVec 2 W64) = 789+primOpTag (VecRemOp IntVec 32 W8) = 790+primOpTag (VecRemOp IntVec 16 W16) = 791+primOpTag (VecRemOp IntVec 8 W32) = 792+primOpTag (VecRemOp IntVec 4 W64) = 793+primOpTag (VecRemOp IntVec 64 W8) = 794+primOpTag (VecRemOp IntVec 32 W16) = 795+primOpTag (VecRemOp IntVec 16 W32) = 796+primOpTag (VecRemOp IntVec 8 W64) = 797+primOpTag (VecRemOp WordVec 16 W8) = 798+primOpTag (VecRemOp WordVec 8 W16) = 799+primOpTag (VecRemOp WordVec 4 W32) = 800+primOpTag (VecRemOp WordVec 2 W64) = 801+primOpTag (VecRemOp WordVec 32 W8) = 802+primOpTag (VecRemOp WordVec 16 W16) = 803+primOpTag (VecRemOp WordVec 8 W32) = 804+primOpTag (VecRemOp WordVec 4 W64) = 805+primOpTag (VecRemOp WordVec 64 W8) = 806+primOpTag (VecRemOp WordVec 32 W16) = 807+primOpTag (VecRemOp WordVec 16 W32) = 808+primOpTag (VecRemOp WordVec 8 W64) = 809+primOpTag (VecNegOp IntVec 16 W8) = 810+primOpTag (VecNegOp IntVec 8 W16) = 811+primOpTag (VecNegOp IntVec 4 W32) = 812+primOpTag (VecNegOp IntVec 2 W64) = 813+primOpTag (VecNegOp IntVec 32 W8) = 814+primOpTag (VecNegOp IntVec 16 W16) = 815+primOpTag (VecNegOp IntVec 8 W32) = 816+primOpTag (VecNegOp IntVec 4 W64) = 817+primOpTag (VecNegOp IntVec 64 W8) = 818+primOpTag (VecNegOp IntVec 32 W16) = 819+primOpTag (VecNegOp IntVec 16 W32) = 820+primOpTag (VecNegOp IntVec 8 W64) = 821+primOpTag (VecNegOp FloatVec 4 W32) = 822+primOpTag (VecNegOp FloatVec 2 W64) = 823+primOpTag (VecNegOp FloatVec 8 W32) = 824+primOpTag (VecNegOp FloatVec 4 W64) = 825+primOpTag (VecNegOp FloatVec 16 W32) = 826+primOpTag (VecNegOp FloatVec 8 W64) = 827+primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 828+primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 829+primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 830+primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 831+primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 832+primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 833+primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 834+primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 835+primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 836+primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 837+primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 838+primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 839+primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 840+primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 841+primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 842+primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 843+primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 844+primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 845+primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 846+primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 847+primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 848+primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 849+primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 850+primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 851+primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 852+primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 853+primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 854+primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 855+primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 856+primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 857+primOpTag (VecReadByteArrayOp IntVec 16 W8) = 858+primOpTag (VecReadByteArrayOp IntVec 8 W16) = 859+primOpTag (VecReadByteArrayOp IntVec 4 W32) = 860+primOpTag (VecReadByteArrayOp IntVec 2 W64) = 861+primOpTag (VecReadByteArrayOp IntVec 32 W8) = 862+primOpTag (VecReadByteArrayOp IntVec 16 W16) = 863+primOpTag (VecReadByteArrayOp IntVec 8 W32) = 864+primOpTag (VecReadByteArrayOp IntVec 4 W64) = 865+primOpTag (VecReadByteArrayOp IntVec 64 W8) = 866+primOpTag (VecReadByteArrayOp IntVec 32 W16) = 867+primOpTag (VecReadByteArrayOp IntVec 16 W32) = 868+primOpTag (VecReadByteArrayOp IntVec 8 W64) = 869+primOpTag (VecReadByteArrayOp WordVec 16 W8) = 870+primOpTag (VecReadByteArrayOp WordVec 8 W16) = 871+primOpTag (VecReadByteArrayOp WordVec 4 W32) = 872+primOpTag (VecReadByteArrayOp WordVec 2 W64) = 873+primOpTag (VecReadByteArrayOp WordVec 32 W8) = 874+primOpTag (VecReadByteArrayOp WordVec 16 W16) = 875+primOpTag (VecReadByteArrayOp WordVec 8 W32) = 876+primOpTag (VecReadByteArrayOp WordVec 4 W64) = 877+primOpTag (VecReadByteArrayOp WordVec 64 W8) = 878+primOpTag (VecReadByteArrayOp WordVec 32 W16) = 879+primOpTag (VecReadByteArrayOp WordVec 16 W32) = 880+primOpTag (VecReadByteArrayOp WordVec 8 W64) = 881+primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 882+primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 883+primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 884+primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 885+primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 886+primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 887+primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 888+primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 889+primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 890+primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 891+primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 892+primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 893+primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 894+primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 895+primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 896+primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 897+primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 898+primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 899+primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 900+primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 901+primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 902+primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 903+primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 904+primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 905+primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 906+primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 907+primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 908+primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 909+primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 910+primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 911+primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 912+primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 913+primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 914+primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 915+primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 916+primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 917+primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 918+primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 919+primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 920+primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 921+primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 922+primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 923+primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 924+primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 925+primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 926+primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 927+primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 928+primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 929+primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 930+primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 931+primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 932+primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 933+primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 934+primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 935+primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 936+primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 937+primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 938+primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 939+primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 940+primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 941+primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 942+primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 943+primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 944+primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 945+primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 946+primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 947+primOpTag (VecReadOffAddrOp IntVec 16 W8) = 948+primOpTag (VecReadOffAddrOp IntVec 8 W16) = 949+primOpTag (VecReadOffAddrOp IntVec 4 W32) = 950+primOpTag (VecReadOffAddrOp IntVec 2 W64) = 951+primOpTag (VecReadOffAddrOp IntVec 32 W8) = 952+primOpTag (VecReadOffAddrOp IntVec 16 W16) = 953+primOpTag (VecReadOffAddrOp IntVec 8 W32) = 954+primOpTag (VecReadOffAddrOp IntVec 4 W64) = 955+primOpTag (VecReadOffAddrOp IntVec 64 W8) = 956+primOpTag (VecReadOffAddrOp IntVec 32 W16) = 957+primOpTag (VecReadOffAddrOp IntVec 16 W32) = 958+primOpTag (VecReadOffAddrOp IntVec 8 W64) = 959+primOpTag (VecReadOffAddrOp WordVec 16 W8) = 960+primOpTag (VecReadOffAddrOp WordVec 8 W16) = 961+primOpTag (VecReadOffAddrOp WordVec 4 W32) = 962+primOpTag (VecReadOffAddrOp WordVec 2 W64) = 963+primOpTag (VecReadOffAddrOp WordVec 32 W8) = 964+primOpTag (VecReadOffAddrOp WordVec 16 W16) = 965+primOpTag (VecReadOffAddrOp WordVec 8 W32) = 966+primOpTag (VecReadOffAddrOp WordVec 4 W64) = 967+primOpTag (VecReadOffAddrOp WordVec 64 W8) = 968+primOpTag (VecReadOffAddrOp WordVec 32 W16) = 969+primOpTag (VecReadOffAddrOp WordVec 16 W32) = 970+primOpTag (VecReadOffAddrOp WordVec 8 W64) = 971+primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 972+primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 973+primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 974+primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 975+primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 976+primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 977+primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 978+primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 979+primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 980+primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 981+primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 982+primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 983+primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 984+primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 985+primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 986+primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 987+primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 988+primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 989+primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 990+primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 991+primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 992+primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 993+primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 994+primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 995+primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 996+primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 997+primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 998+primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 999+primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1000+primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1001+primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1002+primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1003+primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1004+primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1005+primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1006+primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1007+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1008+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1009+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1010+primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1011+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1012+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1013+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1014+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1015+primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1016+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1017+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1018+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1019+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1020+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1021+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1022+primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1023+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1024+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1025+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1026+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1027+primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1028+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1029+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1030+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1031+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1032+primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1033+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1034+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1035+primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1036+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1037+primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1038+primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1039+primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1040+primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1041+primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1042+primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1043+primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1044+primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1045+primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1046+primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1047+primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1048+primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1049+primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1050+primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1051+primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1052+primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1053+primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1054+primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1055+primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1056+primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1057+primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1058+primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1059+primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1060+primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1061+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1062+primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1063+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1064+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1065+primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1066+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1067+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1068+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1069+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1070+primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1071+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1072+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1073+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1074+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1075+primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1076+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1077+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1078+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1079+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1080+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1081+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1082+primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1083+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1084+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1085+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1086+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1087+primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1088+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1089+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1090+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1091+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1092+primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1093+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1094+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1095+primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1096+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1097+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1098+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1099+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1100+primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1101+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1102+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1103+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1104+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1105+primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1106+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1107+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1108+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1109+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1110+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1111+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1112+primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1113+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1114+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1115+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1116+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1117+primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1118+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1119+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1120+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1121+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1122+primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1123+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1124+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1125+primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1126+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1127+primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1128+primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1129+primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1130+primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1131+primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1132+primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1133+primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1134+primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1135+primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1136+primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1137+primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1138+primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1139+primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1140+primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1141+primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1142+primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1143+primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1144+primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1145+primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1146+primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1147+primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1148+primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1149+primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1150+primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1151+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1152+primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1153+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1154+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1155+primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1156+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1157+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1158+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1159+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1160+primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1161+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1162+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1163+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1164+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1165+primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1166+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1167+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1168+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1169+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1170+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1171+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1172+primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1173+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1174+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1175+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1176+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1177+primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1178+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1179+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1180+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1181+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1182+primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1183+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1184+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1185+primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1186+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1187+primOpTag PrefetchByteArrayOp3 = 1188+primOpTag PrefetchMutableByteArrayOp3 = 1189+primOpTag PrefetchAddrOp3 = 1190+primOpTag PrefetchValueOp3 = 1191+primOpTag PrefetchByteArrayOp2 = 1192+primOpTag PrefetchMutableByteArrayOp2 = 1193+primOpTag PrefetchAddrOp2 = 1194+primOpTag PrefetchValueOp2 = 1195+primOpTag PrefetchByteArrayOp1 = 1196+primOpTag PrefetchMutableByteArrayOp1 = 1197+primOpTag PrefetchAddrOp1 = 1198+primOpTag PrefetchValueOp1 = 1199+primOpTag PrefetchByteArrayOp0 = 1200+primOpTag PrefetchMutableByteArrayOp0 = 1201+primOpTag PrefetchAddrOp0 = 1202+primOpTag PrefetchValueOp0 = 1203
+ ghc-lib/stage0/lib/DerivedConstants.h view
@@ -0,0 +1,555 @@+/* This file is created automatically.  Do not edit by hand.*/++#define CONTROL_GROUP_CONST_291 291+#define STD_HDR_SIZE 1+#define PROF_HDR_SIZE 2+#define STACK_DIRTY 1+#define BLOCK_SIZE 4096+#define MBLOCK_SIZE 1048576+#define BLOCKS_PER_MBLOCK 252+#define TICKY_BIN_COUNT 9+#define OFFSET_StgRegTable_rR1 0+#define OFFSET_StgRegTable_rR2 8+#define OFFSET_StgRegTable_rR3 16+#define OFFSET_StgRegTable_rR4 24+#define OFFSET_StgRegTable_rR5 32+#define OFFSET_StgRegTable_rR6 40+#define OFFSET_StgRegTable_rR7 48+#define OFFSET_StgRegTable_rR8 56+#define OFFSET_StgRegTable_rR9 64+#define OFFSET_StgRegTable_rR10 72+#define OFFSET_StgRegTable_rF1 80+#define OFFSET_StgRegTable_rF2 84+#define OFFSET_StgRegTable_rF3 88+#define OFFSET_StgRegTable_rF4 92+#define OFFSET_StgRegTable_rF5 96+#define OFFSET_StgRegTable_rF6 100+#define OFFSET_StgRegTable_rD1 104+#define OFFSET_StgRegTable_rD2 112+#define OFFSET_StgRegTable_rD3 120+#define OFFSET_StgRegTable_rD4 128+#define OFFSET_StgRegTable_rD5 136+#define OFFSET_StgRegTable_rD6 144+#define OFFSET_StgRegTable_rXMM1 152+#define OFFSET_StgRegTable_rXMM2 168+#define OFFSET_StgRegTable_rXMM3 184+#define OFFSET_StgRegTable_rXMM4 200+#define OFFSET_StgRegTable_rXMM5 216+#define OFFSET_StgRegTable_rXMM6 232+#define OFFSET_StgRegTable_rYMM1 248+#define OFFSET_StgRegTable_rYMM2 280+#define OFFSET_StgRegTable_rYMM3 312+#define OFFSET_StgRegTable_rYMM4 344+#define OFFSET_StgRegTable_rYMM5 376+#define OFFSET_StgRegTable_rYMM6 408+#define OFFSET_StgRegTable_rZMM1 440+#define OFFSET_StgRegTable_rZMM2 504+#define OFFSET_StgRegTable_rZMM3 568+#define OFFSET_StgRegTable_rZMM4 632+#define OFFSET_StgRegTable_rZMM5 696+#define OFFSET_StgRegTable_rZMM6 760+#define OFFSET_StgRegTable_rL1 824+#define OFFSET_StgRegTable_rSp 832+#define OFFSET_StgRegTable_rSpLim 840+#define OFFSET_StgRegTable_rHp 848+#define OFFSET_StgRegTable_rHpLim 856+#define OFFSET_StgRegTable_rCCCS 864+#define OFFSET_StgRegTable_rCurrentTSO 872+#define OFFSET_StgRegTable_rCurrentNursery 888+#define OFFSET_StgRegTable_rHpAlloc 904+#define OFFSET_StgRegTable_rRet 912+#define REP_StgRegTable_rRet b64+#define StgRegTable_rRet(__ptr__) REP_StgRegTable_rRet[__ptr__+OFFSET_StgRegTable_rRet]+#define OFFSET_StgRegTable_rNursery 880+#define REP_StgRegTable_rNursery b64+#define StgRegTable_rNursery(__ptr__) REP_StgRegTable_rNursery[__ptr__+OFFSET_StgRegTable_rNursery]+#define OFFSET_stgEagerBlackholeInfo -24+#define OFFSET_stgGCEnter1 -16+#define OFFSET_stgGCFun -8+#define OFFSET_Capability_r 24+#define OFFSET_Capability_lock 1208+#define OFFSET_Capability_no 944+#define REP_Capability_no b32+#define Capability_no(__ptr__) REP_Capability_no[__ptr__+OFFSET_Capability_no]+#define OFFSET_Capability_mut_lists 1016+#define REP_Capability_mut_lists b64+#define Capability_mut_lists(__ptr__) REP_Capability_mut_lists[__ptr__+OFFSET_Capability_mut_lists]+#define OFFSET_Capability_context_switch 1176+#define REP_Capability_context_switch b32+#define Capability_context_switch(__ptr__) REP_Capability_context_switch[__ptr__+OFFSET_Capability_context_switch]+#define OFFSET_Capability_interrupt 1180+#define REP_Capability_interrupt b32+#define Capability_interrupt(__ptr__) REP_Capability_interrupt[__ptr__+OFFSET_Capability_interrupt]+#define OFFSET_Capability_sparks 1312+#define REP_Capability_sparks b64+#define Capability_sparks(__ptr__) REP_Capability_sparks[__ptr__+OFFSET_Capability_sparks]+#define OFFSET_Capability_total_allocated 1184+#define REP_Capability_total_allocated b64+#define Capability_total_allocated(__ptr__) REP_Capability_total_allocated[__ptr__+OFFSET_Capability_total_allocated]+#define OFFSET_Capability_weak_ptr_list_hd 1160+#define REP_Capability_weak_ptr_list_hd b64+#define Capability_weak_ptr_list_hd(__ptr__) REP_Capability_weak_ptr_list_hd[__ptr__+OFFSET_Capability_weak_ptr_list_hd]+#define OFFSET_Capability_weak_ptr_list_tl 1168+#define REP_Capability_weak_ptr_list_tl b64+#define Capability_weak_ptr_list_tl(__ptr__) REP_Capability_weak_ptr_list_tl[__ptr__+OFFSET_Capability_weak_ptr_list_tl]+#define OFFSET_bdescr_start 0+#define REP_bdescr_start b64+#define bdescr_start(__ptr__) REP_bdescr_start[__ptr__+OFFSET_bdescr_start]+#define OFFSET_bdescr_free 8+#define REP_bdescr_free b64+#define bdescr_free(__ptr__) REP_bdescr_free[__ptr__+OFFSET_bdescr_free]+#define OFFSET_bdescr_blocks 48+#define REP_bdescr_blocks b32+#define bdescr_blocks(__ptr__) REP_bdescr_blocks[__ptr__+OFFSET_bdescr_blocks]+#define OFFSET_bdescr_gen_no 40+#define REP_bdescr_gen_no b16+#define bdescr_gen_no(__ptr__) REP_bdescr_gen_no[__ptr__+OFFSET_bdescr_gen_no]+#define OFFSET_bdescr_link 16+#define REP_bdescr_link b64+#define bdescr_link(__ptr__) REP_bdescr_link[__ptr__+OFFSET_bdescr_link]+#define OFFSET_bdescr_flags 46+#define REP_bdescr_flags b16+#define bdescr_flags(__ptr__) REP_bdescr_flags[__ptr__+OFFSET_bdescr_flags]+#define SIZEOF_generation 384+#define OFFSET_generation_n_new_large_words 56+#define REP_generation_n_new_large_words b64+#define generation_n_new_large_words(__ptr__) REP_generation_n_new_large_words[__ptr__+OFFSET_generation_n_new_large_words]+#define OFFSET_generation_weak_ptr_list 112+#define REP_generation_weak_ptr_list b64+#define generation_weak_ptr_list(__ptr__) REP_generation_weak_ptr_list[__ptr__+OFFSET_generation_weak_ptr_list]+#define SIZEOF_CostCentreStack 96+#define OFFSET_CostCentreStack_ccsID 0+#define REP_CostCentreStack_ccsID b64+#define CostCentreStack_ccsID(__ptr__) REP_CostCentreStack_ccsID[__ptr__+OFFSET_CostCentreStack_ccsID]+#define OFFSET_CostCentreStack_mem_alloc 72+#define REP_CostCentreStack_mem_alloc b64+#define CostCentreStack_mem_alloc(__ptr__) REP_CostCentreStack_mem_alloc[__ptr__+OFFSET_CostCentreStack_mem_alloc]+#define OFFSET_CostCentreStack_scc_count 48+#define REP_CostCentreStack_scc_count b64+#define CostCentreStack_scc_count(__ptr__) REP_CostCentreStack_scc_count[__ptr__+OFFSET_CostCentreStack_scc_count]+#define OFFSET_CostCentreStack_prevStack 16+#define REP_CostCentreStack_prevStack b64+#define CostCentreStack_prevStack(__ptr__) REP_CostCentreStack_prevStack[__ptr__+OFFSET_CostCentreStack_prevStack]+#define OFFSET_CostCentre_ccID 0+#define REP_CostCentre_ccID b64+#define CostCentre_ccID(__ptr__) REP_CostCentre_ccID[__ptr__+OFFSET_CostCentre_ccID]+#define OFFSET_CostCentre_link 56+#define REP_CostCentre_link b64+#define CostCentre_link(__ptr__) REP_CostCentre_link[__ptr__+OFFSET_CostCentre_link]+#define OFFSET_StgHeader_info 0+#define REP_StgHeader_info b64+#define StgHeader_info(__ptr__) REP_StgHeader_info[__ptr__+OFFSET_StgHeader_info]+#define OFFSET_StgHeader_ccs 8+#define REP_StgHeader_ccs b64+#define StgHeader_ccs(__ptr__) REP_StgHeader_ccs[__ptr__+OFFSET_StgHeader_ccs]+#define OFFSET_StgHeader_ldvw 16+#define REP_StgHeader_ldvw b64+#define StgHeader_ldvw(__ptr__) REP_StgHeader_ldvw[__ptr__+OFFSET_StgHeader_ldvw]+#define SIZEOF_StgSMPThunkHeader 8+#define OFFSET_StgClosure_payload 0+#define StgClosure_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgClosure_payload + WDS(__ix__)]+#define OFFSET_StgEntCounter_allocs 48+#define REP_StgEntCounter_allocs b64+#define StgEntCounter_allocs(__ptr__) REP_StgEntCounter_allocs[__ptr__+OFFSET_StgEntCounter_allocs]+#define OFFSET_StgEntCounter_allocd 16+#define REP_StgEntCounter_allocd b64+#define StgEntCounter_allocd(__ptr__) REP_StgEntCounter_allocd[__ptr__+OFFSET_StgEntCounter_allocd]+#define OFFSET_StgEntCounter_registeredp 0+#define REP_StgEntCounter_registeredp b64+#define StgEntCounter_registeredp(__ptr__) REP_StgEntCounter_registeredp[__ptr__+OFFSET_StgEntCounter_registeredp]+#define OFFSET_StgEntCounter_link 56+#define REP_StgEntCounter_link b64+#define StgEntCounter_link(__ptr__) REP_StgEntCounter_link[__ptr__+OFFSET_StgEntCounter_link]+#define OFFSET_StgEntCounter_entry_count 40+#define REP_StgEntCounter_entry_count b64+#define StgEntCounter_entry_count(__ptr__) REP_StgEntCounter_entry_count[__ptr__+OFFSET_StgEntCounter_entry_count]+#define SIZEOF_StgUpdateFrame_NoHdr 8+#define SIZEOF_StgUpdateFrame (SIZEOF_StgHeader+8)+#define SIZEOF_StgCatchFrame_NoHdr 16+#define SIZEOF_StgCatchFrame (SIZEOF_StgHeader+16)+#define SIZEOF_StgStopFrame_NoHdr 0+#define SIZEOF_StgStopFrame (SIZEOF_StgHeader+0)+#define SIZEOF_StgMutArrPtrs_NoHdr 16+#define SIZEOF_StgMutArrPtrs (SIZEOF_StgHeader+16)+#define OFFSET_StgMutArrPtrs_ptrs 0+#define REP_StgMutArrPtrs_ptrs b64+#define StgMutArrPtrs_ptrs(__ptr__) REP_StgMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_ptrs]+#define OFFSET_StgMutArrPtrs_size 8+#define REP_StgMutArrPtrs_size b64+#define StgMutArrPtrs_size(__ptr__) REP_StgMutArrPtrs_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_size]+#define SIZEOF_StgSmallMutArrPtrs_NoHdr 8+#define SIZEOF_StgSmallMutArrPtrs (SIZEOF_StgHeader+8)+#define OFFSET_StgSmallMutArrPtrs_ptrs 0+#define REP_StgSmallMutArrPtrs_ptrs b64+#define StgSmallMutArrPtrs_ptrs(__ptr__) REP_StgSmallMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgSmallMutArrPtrs_ptrs]+#define SIZEOF_StgArrBytes_NoHdr 8+#define SIZEOF_StgArrBytes (SIZEOF_StgHeader+8)+#define OFFSET_StgArrBytes_bytes 0+#define REP_StgArrBytes_bytes b64+#define StgArrBytes_bytes(__ptr__) REP_StgArrBytes_bytes[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_bytes]+#define OFFSET_StgArrBytes_payload 8+#define StgArrBytes_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_payload + WDS(__ix__)]+#define OFFSET_StgTSO__link 0+#define REP_StgTSO__link b64+#define StgTSO__link(__ptr__) REP_StgTSO__link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO__link]+#define OFFSET_StgTSO_global_link 8+#define REP_StgTSO_global_link b64+#define StgTSO_global_link(__ptr__) REP_StgTSO_global_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_global_link]+#define OFFSET_StgTSO_what_next 24+#define REP_StgTSO_what_next b16+#define StgTSO_what_next(__ptr__) REP_StgTSO_what_next[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_what_next]+#define OFFSET_StgTSO_why_blocked 26+#define REP_StgTSO_why_blocked b16+#define StgTSO_why_blocked(__ptr__) REP_StgTSO_why_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_why_blocked]+#define OFFSET_StgTSO_block_info 32+#define REP_StgTSO_block_info b64+#define StgTSO_block_info(__ptr__) REP_StgTSO_block_info[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_block_info]+#define OFFSET_StgTSO_blocked_exceptions 80+#define REP_StgTSO_blocked_exceptions b64+#define StgTSO_blocked_exceptions(__ptr__) REP_StgTSO_blocked_exceptions[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_blocked_exceptions]+#define OFFSET_StgTSO_id 40+#define REP_StgTSO_id b32+#define StgTSO_id(__ptr__) REP_StgTSO_id[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_id]+#define OFFSET_StgTSO_cap 64+#define REP_StgTSO_cap b64+#define StgTSO_cap(__ptr__) REP_StgTSO_cap[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cap]+#define OFFSET_StgTSO_saved_errno 44+#define REP_StgTSO_saved_errno b32+#define StgTSO_saved_errno(__ptr__) REP_StgTSO_saved_errno[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_saved_errno]+#define OFFSET_StgTSO_trec 72+#define REP_StgTSO_trec b64+#define StgTSO_trec(__ptr__) REP_StgTSO_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_trec]+#define OFFSET_StgTSO_flags 28+#define REP_StgTSO_flags b32+#define StgTSO_flags(__ptr__) REP_StgTSO_flags[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_flags]+#define OFFSET_StgTSO_dirty 48+#define REP_StgTSO_dirty b32+#define StgTSO_dirty(__ptr__) REP_StgTSO_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_dirty]+#define OFFSET_StgTSO_bq 88+#define REP_StgTSO_bq b64+#define StgTSO_bq(__ptr__) REP_StgTSO_bq[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_bq]+#define OFFSET_StgTSO_alloc_limit 96+#define REP_StgTSO_alloc_limit b64+#define StgTSO_alloc_limit(__ptr__) REP_StgTSO_alloc_limit[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_alloc_limit]+#define OFFSET_StgTSO_cccs 112+#define REP_StgTSO_cccs b64+#define StgTSO_cccs(__ptr__) REP_StgTSO_cccs[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cccs]+#define OFFSET_StgTSO_stackobj 16+#define REP_StgTSO_stackobj b64+#define StgTSO_stackobj(__ptr__) REP_StgTSO_stackobj[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_stackobj]+#define OFFSET_StgStack_sp 8+#define REP_StgStack_sp b64+#define StgStack_sp(__ptr__) REP_StgStack_sp[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_sp]+#define OFFSET_StgStack_stack 16+#define OFFSET_StgStack_stack_size 0+#define REP_StgStack_stack_size b32+#define StgStack_stack_size(__ptr__) REP_StgStack_stack_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_stack_size]+#define OFFSET_StgStack_dirty 4+#define REP_StgStack_dirty b8+#define StgStack_dirty(__ptr__) REP_StgStack_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_dirty]+#define SIZEOF_StgTSOProfInfo 8+#define OFFSET_StgUpdateFrame_updatee 0+#define REP_StgUpdateFrame_updatee b64+#define StgUpdateFrame_updatee(__ptr__) REP_StgUpdateFrame_updatee[__ptr__+SIZEOF_StgHeader+OFFSET_StgUpdateFrame_updatee]+#define OFFSET_StgCatchFrame_handler 8+#define REP_StgCatchFrame_handler b64+#define StgCatchFrame_handler(__ptr__) REP_StgCatchFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_handler]+#define OFFSET_StgCatchFrame_exceptions_blocked 0+#define REP_StgCatchFrame_exceptions_blocked b64+#define StgCatchFrame_exceptions_blocked(__ptr__) REP_StgCatchFrame_exceptions_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_exceptions_blocked]+#define SIZEOF_StgPAP_NoHdr 16+#define SIZEOF_StgPAP (SIZEOF_StgHeader+16)+#define OFFSET_StgPAP_n_args 4+#define REP_StgPAP_n_args b32+#define StgPAP_n_args(__ptr__) REP_StgPAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_n_args]+#define OFFSET_StgPAP_fun 8+#define REP_StgPAP_fun gcptr+#define StgPAP_fun(__ptr__) REP_StgPAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_fun]+#define OFFSET_StgPAP_arity 0+#define REP_StgPAP_arity b32+#define StgPAP_arity(__ptr__) REP_StgPAP_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_arity]+#define OFFSET_StgPAP_payload 16+#define StgPAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_payload + WDS(__ix__)]+#define SIZEOF_StgAP_NoThunkHdr 16+#define SIZEOF_StgAP_NoHdr 24+#define SIZEOF_StgAP (SIZEOF_StgHeader+24)+#define OFFSET_StgAP_n_args 12+#define REP_StgAP_n_args b32+#define StgAP_n_args(__ptr__) REP_StgAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_n_args]+#define OFFSET_StgAP_fun 16+#define REP_StgAP_fun gcptr+#define StgAP_fun(__ptr__) REP_StgAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_fun]+#define OFFSET_StgAP_payload 24+#define StgAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_payload + WDS(__ix__)]+#define SIZEOF_StgAP_STACK_NoThunkHdr 16+#define SIZEOF_StgAP_STACK_NoHdr 24+#define SIZEOF_StgAP_STACK (SIZEOF_StgHeader+24)+#define OFFSET_StgAP_STACK_size 8+#define REP_StgAP_STACK_size b64+#define StgAP_STACK_size(__ptr__) REP_StgAP_STACK_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_size]+#define OFFSET_StgAP_STACK_fun 16+#define REP_StgAP_STACK_fun gcptr+#define StgAP_STACK_fun(__ptr__) REP_StgAP_STACK_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_fun]+#define OFFSET_StgAP_STACK_payload 24+#define StgAP_STACK_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_payload + WDS(__ix__)]+#define SIZEOF_StgSelector_NoThunkHdr 8+#define SIZEOF_StgSelector_NoHdr 16+#define SIZEOF_StgSelector (SIZEOF_StgHeader+16)+#define OFFSET_StgInd_indirectee 0+#define REP_StgInd_indirectee gcptr+#define StgInd_indirectee(__ptr__) REP_StgInd_indirectee[__ptr__+SIZEOF_StgHeader+OFFSET_StgInd_indirectee]+#define SIZEOF_StgMutVar_NoHdr 8+#define SIZEOF_StgMutVar (SIZEOF_StgHeader+8)+#define OFFSET_StgMutVar_var 0+#define REP_StgMutVar_var b64+#define StgMutVar_var(__ptr__) REP_StgMutVar_var[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutVar_var]+#define SIZEOF_StgAtomicallyFrame_NoHdr 16+#define SIZEOF_StgAtomicallyFrame (SIZEOF_StgHeader+16)+#define OFFSET_StgAtomicallyFrame_code 0+#define REP_StgAtomicallyFrame_code b64+#define StgAtomicallyFrame_code(__ptr__) REP_StgAtomicallyFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_code]+#define OFFSET_StgAtomicallyFrame_result 8+#define REP_StgAtomicallyFrame_result b64+#define StgAtomicallyFrame_result(__ptr__) REP_StgAtomicallyFrame_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_result]+#define OFFSET_StgTRecHeader_enclosing_trec 0+#define REP_StgTRecHeader_enclosing_trec b64+#define StgTRecHeader_enclosing_trec(__ptr__) REP_StgTRecHeader_enclosing_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTRecHeader_enclosing_trec]+#define SIZEOF_StgCatchSTMFrame_NoHdr 16+#define SIZEOF_StgCatchSTMFrame (SIZEOF_StgHeader+16)+#define OFFSET_StgCatchSTMFrame_handler 8+#define REP_StgCatchSTMFrame_handler b64+#define StgCatchSTMFrame_handler(__ptr__) REP_StgCatchSTMFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_handler]+#define OFFSET_StgCatchSTMFrame_code 0+#define REP_StgCatchSTMFrame_code b64+#define StgCatchSTMFrame_code(__ptr__) REP_StgCatchSTMFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_code]+#define SIZEOF_StgCatchRetryFrame_NoHdr 24+#define SIZEOF_StgCatchRetryFrame (SIZEOF_StgHeader+24)+#define OFFSET_StgCatchRetryFrame_running_alt_code 0+#define REP_StgCatchRetryFrame_running_alt_code b64+#define StgCatchRetryFrame_running_alt_code(__ptr__) REP_StgCatchRetryFrame_running_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_running_alt_code]+#define OFFSET_StgCatchRetryFrame_first_code 8+#define REP_StgCatchRetryFrame_first_code b64+#define StgCatchRetryFrame_first_code(__ptr__) REP_StgCatchRetryFrame_first_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_first_code]+#define OFFSET_StgCatchRetryFrame_alt_code 16+#define REP_StgCatchRetryFrame_alt_code b64+#define StgCatchRetryFrame_alt_code(__ptr__) REP_StgCatchRetryFrame_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_alt_code]+#define OFFSET_StgTVarWatchQueue_closure 0+#define REP_StgTVarWatchQueue_closure b64+#define StgTVarWatchQueue_closure(__ptr__) REP_StgTVarWatchQueue_closure[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_closure]+#define OFFSET_StgTVarWatchQueue_next_queue_entry 8+#define REP_StgTVarWatchQueue_next_queue_entry b64+#define StgTVarWatchQueue_next_queue_entry(__ptr__) REP_StgTVarWatchQueue_next_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_next_queue_entry]+#define OFFSET_StgTVarWatchQueue_prev_queue_entry 16+#define REP_StgTVarWatchQueue_prev_queue_entry b64+#define StgTVarWatchQueue_prev_queue_entry(__ptr__) REP_StgTVarWatchQueue_prev_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_prev_queue_entry]+#define SIZEOF_StgTVar_NoHdr 24+#define SIZEOF_StgTVar (SIZEOF_StgHeader+24)+#define OFFSET_StgTVar_current_value 0+#define REP_StgTVar_current_value b64+#define StgTVar_current_value(__ptr__) REP_StgTVar_current_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_current_value]+#define OFFSET_StgTVar_first_watch_queue_entry 8+#define REP_StgTVar_first_watch_queue_entry b64+#define StgTVar_first_watch_queue_entry(__ptr__) REP_StgTVar_first_watch_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_first_watch_queue_entry]+#define OFFSET_StgTVar_num_updates 16+#define REP_StgTVar_num_updates b64+#define StgTVar_num_updates(__ptr__) REP_StgTVar_num_updates[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_num_updates]+#define SIZEOF_StgWeak_NoHdr 40+#define SIZEOF_StgWeak (SIZEOF_StgHeader+40)+#define OFFSET_StgWeak_link 32+#define REP_StgWeak_link b64+#define StgWeak_link(__ptr__) REP_StgWeak_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_link]+#define OFFSET_StgWeak_key 8+#define REP_StgWeak_key b64+#define StgWeak_key(__ptr__) REP_StgWeak_key[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_key]+#define OFFSET_StgWeak_value 16+#define REP_StgWeak_value b64+#define StgWeak_value(__ptr__) REP_StgWeak_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_value]+#define OFFSET_StgWeak_finalizer 24+#define REP_StgWeak_finalizer b64+#define StgWeak_finalizer(__ptr__) REP_StgWeak_finalizer[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_finalizer]+#define OFFSET_StgWeak_cfinalizers 0+#define REP_StgWeak_cfinalizers b64+#define StgWeak_cfinalizers(__ptr__) REP_StgWeak_cfinalizers[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_cfinalizers]+#define SIZEOF_StgCFinalizerList_NoHdr 40+#define SIZEOF_StgCFinalizerList (SIZEOF_StgHeader+40)+#define OFFSET_StgCFinalizerList_link 0+#define REP_StgCFinalizerList_link b64+#define StgCFinalizerList_link(__ptr__) REP_StgCFinalizerList_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_link]+#define OFFSET_StgCFinalizerList_fptr 8+#define REP_StgCFinalizerList_fptr b64+#define StgCFinalizerList_fptr(__ptr__) REP_StgCFinalizerList_fptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_fptr]+#define OFFSET_StgCFinalizerList_ptr 16+#define REP_StgCFinalizerList_ptr b64+#define StgCFinalizerList_ptr(__ptr__) REP_StgCFinalizerList_ptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_ptr]+#define OFFSET_StgCFinalizerList_eptr 24+#define REP_StgCFinalizerList_eptr b64+#define StgCFinalizerList_eptr(__ptr__) REP_StgCFinalizerList_eptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_eptr]+#define OFFSET_StgCFinalizerList_flag 32+#define REP_StgCFinalizerList_flag b64+#define StgCFinalizerList_flag(__ptr__) REP_StgCFinalizerList_flag[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_flag]+#define SIZEOF_StgMVar_NoHdr 24+#define SIZEOF_StgMVar (SIZEOF_StgHeader+24)+#define OFFSET_StgMVar_head 0+#define REP_StgMVar_head b64+#define StgMVar_head(__ptr__) REP_StgMVar_head[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_head]+#define OFFSET_StgMVar_tail 8+#define REP_StgMVar_tail b64+#define StgMVar_tail(__ptr__) REP_StgMVar_tail[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_tail]+#define OFFSET_StgMVar_value 16+#define REP_StgMVar_value b64+#define StgMVar_value(__ptr__) REP_StgMVar_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_value]+#define SIZEOF_StgMVarTSOQueue_NoHdr 16+#define SIZEOF_StgMVarTSOQueue (SIZEOF_StgHeader+16)+#define OFFSET_StgMVarTSOQueue_link 0+#define REP_StgMVarTSOQueue_link b64+#define StgMVarTSOQueue_link(__ptr__) REP_StgMVarTSOQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_link]+#define OFFSET_StgMVarTSOQueue_tso 8+#define REP_StgMVarTSOQueue_tso b64+#define StgMVarTSOQueue_tso(__ptr__) REP_StgMVarTSOQueue_tso[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_tso]+#define SIZEOF_StgBCO_NoHdr 32+#define SIZEOF_StgBCO (SIZEOF_StgHeader+32)+#define OFFSET_StgBCO_instrs 0+#define REP_StgBCO_instrs b64+#define StgBCO_instrs(__ptr__) REP_StgBCO_instrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_instrs]+#define OFFSET_StgBCO_literals 8+#define REP_StgBCO_literals b64+#define StgBCO_literals(__ptr__) REP_StgBCO_literals[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_literals]+#define OFFSET_StgBCO_ptrs 16+#define REP_StgBCO_ptrs b64+#define StgBCO_ptrs(__ptr__) REP_StgBCO_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_ptrs]+#define OFFSET_StgBCO_arity 24+#define REP_StgBCO_arity b32+#define StgBCO_arity(__ptr__) REP_StgBCO_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_arity]+#define OFFSET_StgBCO_size 28+#define REP_StgBCO_size b32+#define StgBCO_size(__ptr__) REP_StgBCO_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_size]+#define OFFSET_StgBCO_bitmap 32+#define StgBCO_bitmap(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_bitmap + WDS(__ix__)]+#define SIZEOF_StgStableName_NoHdr 8+#define SIZEOF_StgStableName (SIZEOF_StgHeader+8)+#define OFFSET_StgStableName_sn 0+#define REP_StgStableName_sn b64+#define StgStableName_sn(__ptr__) REP_StgStableName_sn[__ptr__+SIZEOF_StgHeader+OFFSET_StgStableName_sn]+#define SIZEOF_StgBlockingQueue_NoHdr 32+#define SIZEOF_StgBlockingQueue (SIZEOF_StgHeader+32)+#define OFFSET_StgBlockingQueue_bh 8+#define REP_StgBlockingQueue_bh b64+#define StgBlockingQueue_bh(__ptr__) REP_StgBlockingQueue_bh[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_bh]+#define OFFSET_StgBlockingQueue_owner 16+#define REP_StgBlockingQueue_owner b64+#define StgBlockingQueue_owner(__ptr__) REP_StgBlockingQueue_owner[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_owner]+#define OFFSET_StgBlockingQueue_queue 24+#define REP_StgBlockingQueue_queue b64+#define StgBlockingQueue_queue(__ptr__) REP_StgBlockingQueue_queue[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_queue]+#define OFFSET_StgBlockingQueue_link 0+#define REP_StgBlockingQueue_link b64+#define StgBlockingQueue_link(__ptr__) REP_StgBlockingQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_link]+#define SIZEOF_MessageBlackHole_NoHdr 24+#define SIZEOF_MessageBlackHole (SIZEOF_StgHeader+24)+#define OFFSET_MessageBlackHole_link 0+#define REP_MessageBlackHole_link b64+#define MessageBlackHole_link(__ptr__) REP_MessageBlackHole_link[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_link]+#define OFFSET_MessageBlackHole_tso 8+#define REP_MessageBlackHole_tso b64+#define MessageBlackHole_tso(__ptr__) REP_MessageBlackHole_tso[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_tso]+#define OFFSET_MessageBlackHole_bh 16+#define REP_MessageBlackHole_bh b64+#define MessageBlackHole_bh(__ptr__) REP_MessageBlackHole_bh[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_bh]+#define SIZEOF_StgCompactNFData_NoHdr 64+#define SIZEOF_StgCompactNFData (SIZEOF_StgHeader+64)+#define OFFSET_StgCompactNFData_totalW 0+#define REP_StgCompactNFData_totalW b64+#define StgCompactNFData_totalW(__ptr__) REP_StgCompactNFData_totalW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_totalW]+#define OFFSET_StgCompactNFData_autoBlockW 8+#define REP_StgCompactNFData_autoBlockW b64+#define StgCompactNFData_autoBlockW(__ptr__) REP_StgCompactNFData_autoBlockW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_autoBlockW]+#define OFFSET_StgCompactNFData_nursery 32+#define REP_StgCompactNFData_nursery b64+#define StgCompactNFData_nursery(__ptr__) REP_StgCompactNFData_nursery[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_nursery]+#define OFFSET_StgCompactNFData_last 40+#define REP_StgCompactNFData_last b64+#define StgCompactNFData_last(__ptr__) REP_StgCompactNFData_last[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_last]+#define OFFSET_StgCompactNFData_hp 16+#define REP_StgCompactNFData_hp b64+#define StgCompactNFData_hp(__ptr__) REP_StgCompactNFData_hp[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hp]+#define OFFSET_StgCompactNFData_hpLim 24+#define REP_StgCompactNFData_hpLim b64+#define StgCompactNFData_hpLim(__ptr__) REP_StgCompactNFData_hpLim[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hpLim]+#define OFFSET_StgCompactNFData_hash 48+#define REP_StgCompactNFData_hash b64+#define StgCompactNFData_hash(__ptr__) REP_StgCompactNFData_hash[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hash]+#define OFFSET_StgCompactNFData_result 56+#define REP_StgCompactNFData_result b64+#define StgCompactNFData_result(__ptr__) REP_StgCompactNFData_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_result]+#define SIZEOF_StgCompactNFDataBlock 24+#define OFFSET_StgCompactNFDataBlock_self 0+#define REP_StgCompactNFDataBlock_self b64+#define StgCompactNFDataBlock_self(__ptr__) REP_StgCompactNFDataBlock_self[__ptr__+OFFSET_StgCompactNFDataBlock_self]+#define OFFSET_StgCompactNFDataBlock_owner 8+#define REP_StgCompactNFDataBlock_owner b64+#define StgCompactNFDataBlock_owner(__ptr__) REP_StgCompactNFDataBlock_owner[__ptr__+OFFSET_StgCompactNFDataBlock_owner]+#define OFFSET_StgCompactNFDataBlock_next 16+#define REP_StgCompactNFDataBlock_next b64+#define StgCompactNFDataBlock_next(__ptr__) REP_StgCompactNFDataBlock_next[__ptr__+OFFSET_StgCompactNFDataBlock_next]+#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 277+#define REP_RtsFlags_ProfFlags_showCCSOnException b8+#define RtsFlags_ProfFlags_showCCSOnException(__ptr__) REP_RtsFlags_ProfFlags_showCCSOnException[__ptr__+OFFSET_RtsFlags_ProfFlags_showCCSOnException]+#define OFFSET_RtsFlags_DebugFlags_apply 220+#define REP_RtsFlags_DebugFlags_apply b8+#define RtsFlags_DebugFlags_apply(__ptr__) REP_RtsFlags_DebugFlags_apply[__ptr__+OFFSET_RtsFlags_DebugFlags_apply]+#define OFFSET_RtsFlags_DebugFlags_sanity 215+#define REP_RtsFlags_DebugFlags_sanity b8+#define RtsFlags_DebugFlags_sanity(__ptr__) REP_RtsFlags_DebugFlags_sanity[__ptr__+OFFSET_RtsFlags_DebugFlags_sanity]+#define OFFSET_RtsFlags_DebugFlags_weak 210+#define REP_RtsFlags_DebugFlags_weak b8+#define RtsFlags_DebugFlags_weak(__ptr__) REP_RtsFlags_DebugFlags_weak[__ptr__+OFFSET_RtsFlags_DebugFlags_weak]+#define OFFSET_RtsFlags_GcFlags_initialStkSize 16+#define REP_RtsFlags_GcFlags_initialStkSize b32+#define RtsFlags_GcFlags_initialStkSize(__ptr__) REP_RtsFlags_GcFlags_initialStkSize[__ptr__+OFFSET_RtsFlags_GcFlags_initialStkSize]+#define OFFSET_RtsFlags_MiscFlags_tickInterval 184+#define REP_RtsFlags_MiscFlags_tickInterval b64+#define RtsFlags_MiscFlags_tickInterval(__ptr__) REP_RtsFlags_MiscFlags_tickInterval[__ptr__+OFFSET_RtsFlags_MiscFlags_tickInterval]+#define SIZEOF_StgFunInfoExtraFwd 32+#define OFFSET_StgFunInfoExtraFwd_slow_apply 24+#define REP_StgFunInfoExtraFwd_slow_apply b64+#define StgFunInfoExtraFwd_slow_apply(__ptr__) REP_StgFunInfoExtraFwd_slow_apply[__ptr__+OFFSET_StgFunInfoExtraFwd_slow_apply]+#define OFFSET_StgFunInfoExtraFwd_fun_type 0+#define REP_StgFunInfoExtraFwd_fun_type b32+#define StgFunInfoExtraFwd_fun_type(__ptr__) REP_StgFunInfoExtraFwd_fun_type[__ptr__+OFFSET_StgFunInfoExtraFwd_fun_type]+#define OFFSET_StgFunInfoExtraFwd_arity 4+#define REP_StgFunInfoExtraFwd_arity b32+#define StgFunInfoExtraFwd_arity(__ptr__) REP_StgFunInfoExtraFwd_arity[__ptr__+OFFSET_StgFunInfoExtraFwd_arity]+#define OFFSET_StgFunInfoExtraFwd_bitmap 16+#define REP_StgFunInfoExtraFwd_bitmap b64+#define StgFunInfoExtraFwd_bitmap(__ptr__) REP_StgFunInfoExtraFwd_bitmap[__ptr__+OFFSET_StgFunInfoExtraFwd_bitmap]+#define SIZEOF_StgFunInfoExtraRev 24+#define OFFSET_StgFunInfoExtraRev_slow_apply_offset 0+#define REP_StgFunInfoExtraRev_slow_apply_offset b32+#define StgFunInfoExtraRev_slow_apply_offset(__ptr__) REP_StgFunInfoExtraRev_slow_apply_offset[__ptr__+OFFSET_StgFunInfoExtraRev_slow_apply_offset]+#define OFFSET_StgFunInfoExtraRev_fun_type 16+#define REP_StgFunInfoExtraRev_fun_type b32+#define StgFunInfoExtraRev_fun_type(__ptr__) REP_StgFunInfoExtraRev_fun_type[__ptr__+OFFSET_StgFunInfoExtraRev_fun_type]+#define OFFSET_StgFunInfoExtraRev_arity 20+#define REP_StgFunInfoExtraRev_arity b32+#define StgFunInfoExtraRev_arity(__ptr__) REP_StgFunInfoExtraRev_arity[__ptr__+OFFSET_StgFunInfoExtraRev_arity]+#define OFFSET_StgFunInfoExtraRev_bitmap 8+#define REP_StgFunInfoExtraRev_bitmap b64+#define StgFunInfoExtraRev_bitmap(__ptr__) REP_StgFunInfoExtraRev_bitmap[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap]+#define OFFSET_StgFunInfoExtraRev_bitmap_offset 8+#define REP_StgFunInfoExtraRev_bitmap_offset b32+#define StgFunInfoExtraRev_bitmap_offset(__ptr__) REP_StgFunInfoExtraRev_bitmap_offset[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap_offset]+#define OFFSET_StgLargeBitmap_size 0+#define REP_StgLargeBitmap_size b64+#define StgLargeBitmap_size(__ptr__) REP_StgLargeBitmap_size[__ptr__+OFFSET_StgLargeBitmap_size]+#define OFFSET_StgLargeBitmap_bitmap 8+#define SIZEOF_snEntry 24+#define OFFSET_snEntry_sn_obj 16+#define REP_snEntry_sn_obj b64+#define snEntry_sn_obj(__ptr__) REP_snEntry_sn_obj[__ptr__+OFFSET_snEntry_sn_obj]+#define OFFSET_snEntry_addr 0+#define REP_snEntry_addr b64+#define snEntry_addr(__ptr__) REP_snEntry_addr[__ptr__+OFFSET_snEntry_addr]+#define SIZEOF_spEntry 8+#define OFFSET_spEntry_addr 0+#define REP_spEntry_addr b64+#define spEntry_addr(__ptr__) REP_spEntry_addr[__ptr__+OFFSET_spEntry_addr]
+ ghc-lib/stage0/lib/GHCConstantsHaskellExports.hs view
@@ -0,0 +1,125 @@+    cONTROL_GROUP_CONST_291,+    sTD_HDR_SIZE,+    pROF_HDR_SIZE,+    bLOCK_SIZE,+    bLOCKS_PER_MBLOCK,+    tICKY_BIN_COUNT,+    oFFSET_StgRegTable_rR1,+    oFFSET_StgRegTable_rR2,+    oFFSET_StgRegTable_rR3,+    oFFSET_StgRegTable_rR4,+    oFFSET_StgRegTable_rR5,+    oFFSET_StgRegTable_rR6,+    oFFSET_StgRegTable_rR7,+    oFFSET_StgRegTable_rR8,+    oFFSET_StgRegTable_rR9,+    oFFSET_StgRegTable_rR10,+    oFFSET_StgRegTable_rF1,+    oFFSET_StgRegTable_rF2,+    oFFSET_StgRegTable_rF3,+    oFFSET_StgRegTable_rF4,+    oFFSET_StgRegTable_rF5,+    oFFSET_StgRegTable_rF6,+    oFFSET_StgRegTable_rD1,+    oFFSET_StgRegTable_rD2,+    oFFSET_StgRegTable_rD3,+    oFFSET_StgRegTable_rD4,+    oFFSET_StgRegTable_rD5,+    oFFSET_StgRegTable_rD6,+    oFFSET_StgRegTable_rXMM1,+    oFFSET_StgRegTable_rXMM2,+    oFFSET_StgRegTable_rXMM3,+    oFFSET_StgRegTable_rXMM4,+    oFFSET_StgRegTable_rXMM5,+    oFFSET_StgRegTable_rXMM6,+    oFFSET_StgRegTable_rYMM1,+    oFFSET_StgRegTable_rYMM2,+    oFFSET_StgRegTable_rYMM3,+    oFFSET_StgRegTable_rYMM4,+    oFFSET_StgRegTable_rYMM5,+    oFFSET_StgRegTable_rYMM6,+    oFFSET_StgRegTable_rZMM1,+    oFFSET_StgRegTable_rZMM2,+    oFFSET_StgRegTable_rZMM3,+    oFFSET_StgRegTable_rZMM4,+    oFFSET_StgRegTable_rZMM5,+    oFFSET_StgRegTable_rZMM6,+    oFFSET_StgRegTable_rL1,+    oFFSET_StgRegTable_rSp,+    oFFSET_StgRegTable_rSpLim,+    oFFSET_StgRegTable_rHp,+    oFFSET_StgRegTable_rHpLim,+    oFFSET_StgRegTable_rCCCS,+    oFFSET_StgRegTable_rCurrentTSO,+    oFFSET_StgRegTable_rCurrentNursery,+    oFFSET_StgRegTable_rHpAlloc,+    oFFSET_stgEagerBlackholeInfo,+    oFFSET_stgGCEnter1,+    oFFSET_stgGCFun,+    oFFSET_Capability_r,+    oFFSET_bdescr_start,+    oFFSET_bdescr_free,+    oFFSET_bdescr_blocks,+    oFFSET_bdescr_flags,+    sIZEOF_CostCentreStack,+    oFFSET_CostCentreStack_mem_alloc,+    oFFSET_CostCentreStack_scc_count,+    oFFSET_StgHeader_ccs,+    oFFSET_StgHeader_ldvw,+    sIZEOF_StgSMPThunkHeader,+    oFFSET_StgEntCounter_allocs,+    oFFSET_StgEntCounter_allocd,+    oFFSET_StgEntCounter_registeredp,+    oFFSET_StgEntCounter_link,+    oFFSET_StgEntCounter_entry_count,+    sIZEOF_StgUpdateFrame_NoHdr,+    sIZEOF_StgMutArrPtrs_NoHdr,+    oFFSET_StgMutArrPtrs_ptrs,+    oFFSET_StgMutArrPtrs_size,+    sIZEOF_StgSmallMutArrPtrs_NoHdr,+    oFFSET_StgSmallMutArrPtrs_ptrs,+    sIZEOF_StgArrBytes_NoHdr,+    oFFSET_StgArrBytes_bytes,+    oFFSET_StgTSO_alloc_limit,+    oFFSET_StgTSO_cccs,+    oFFSET_StgTSO_stackobj,+    oFFSET_StgStack_sp,+    oFFSET_StgStack_stack,+    oFFSET_StgUpdateFrame_updatee,+    oFFSET_StgFunInfoExtraFwd_arity,+    sIZEOF_StgFunInfoExtraRev,+    oFFSET_StgFunInfoExtraRev_arity,+    mAX_SPEC_SELECTEE_SIZE,+    mAX_SPEC_AP_SIZE,+    mIN_PAYLOAD_SIZE,+    mIN_INTLIKE,+    mAX_INTLIKE,+    mIN_CHARLIKE,+    mAX_CHARLIKE,+    mUT_ARR_PTRS_CARD_BITS,+    mAX_Vanilla_REG,+    mAX_Float_REG,+    mAX_Double_REG,+    mAX_Long_REG,+    mAX_XMM_REG,+    mAX_Real_Vanilla_REG,+    mAX_Real_Float_REG,+    mAX_Real_Double_REG,+    mAX_Real_XMM_REG,+    mAX_Real_Long_REG,+    rESERVED_C_STACK_BYTES,+    rESERVED_STACK_WORDS,+    aP_STACK_SPLIM,+    wORD_SIZE,+    dOUBLE_SIZE,+    cINT_SIZE,+    cLONG_SIZE,+    cLONG_LONG_SIZE,+    bITMAP_BITS_SHIFT,+    tAG_BITS,+    wORDS_BIGENDIAN,+    dYNAMIC_BY_DEFAULT,+    lDV_SHIFT,+    iLDV_CREATE_MASK,+    iLDV_STATE_CREATE,+    iLDV_STATE_USE,
+ ghc-lib/stage0/lib/GHCConstantsHaskellType.hs view
@@ -0,0 +1,133 @@+data PlatformConstants = PlatformConstants {+      pc_CONTROL_GROUP_CONST_291 :: Int,+      pc_STD_HDR_SIZE :: Int,+      pc_PROF_HDR_SIZE :: Int,+      pc_BLOCK_SIZE :: Int,+      pc_BLOCKS_PER_MBLOCK :: Int,+      pc_TICKY_BIN_COUNT :: Int,+      pc_OFFSET_StgRegTable_rR1 :: Int,+      pc_OFFSET_StgRegTable_rR2 :: Int,+      pc_OFFSET_StgRegTable_rR3 :: Int,+      pc_OFFSET_StgRegTable_rR4 :: Int,+      pc_OFFSET_StgRegTable_rR5 :: Int,+      pc_OFFSET_StgRegTable_rR6 :: Int,+      pc_OFFSET_StgRegTable_rR7 :: Int,+      pc_OFFSET_StgRegTable_rR8 :: Int,+      pc_OFFSET_StgRegTable_rR9 :: Int,+      pc_OFFSET_StgRegTable_rR10 :: Int,+      pc_OFFSET_StgRegTable_rF1 :: Int,+      pc_OFFSET_StgRegTable_rF2 :: Int,+      pc_OFFSET_StgRegTable_rF3 :: Int,+      pc_OFFSET_StgRegTable_rF4 :: Int,+      pc_OFFSET_StgRegTable_rF5 :: Int,+      pc_OFFSET_StgRegTable_rF6 :: Int,+      pc_OFFSET_StgRegTable_rD1 :: Int,+      pc_OFFSET_StgRegTable_rD2 :: Int,+      pc_OFFSET_StgRegTable_rD3 :: Int,+      pc_OFFSET_StgRegTable_rD4 :: Int,+      pc_OFFSET_StgRegTable_rD5 :: Int,+      pc_OFFSET_StgRegTable_rD6 :: Int,+      pc_OFFSET_StgRegTable_rXMM1 :: Int,+      pc_OFFSET_StgRegTable_rXMM2 :: Int,+      pc_OFFSET_StgRegTable_rXMM3 :: Int,+      pc_OFFSET_StgRegTable_rXMM4 :: Int,+      pc_OFFSET_StgRegTable_rXMM5 :: Int,+      pc_OFFSET_StgRegTable_rXMM6 :: Int,+      pc_OFFSET_StgRegTable_rYMM1 :: Int,+      pc_OFFSET_StgRegTable_rYMM2 :: Int,+      pc_OFFSET_StgRegTable_rYMM3 :: Int,+      pc_OFFSET_StgRegTable_rYMM4 :: Int,+      pc_OFFSET_StgRegTable_rYMM5 :: Int,+      pc_OFFSET_StgRegTable_rYMM6 :: Int,+      pc_OFFSET_StgRegTable_rZMM1 :: Int,+      pc_OFFSET_StgRegTable_rZMM2 :: Int,+      pc_OFFSET_StgRegTable_rZMM3 :: Int,+      pc_OFFSET_StgRegTable_rZMM4 :: Int,+      pc_OFFSET_StgRegTable_rZMM5 :: Int,+      pc_OFFSET_StgRegTable_rZMM6 :: Int,+      pc_OFFSET_StgRegTable_rL1 :: Int,+      pc_OFFSET_StgRegTable_rSp :: Int,+      pc_OFFSET_StgRegTable_rSpLim :: Int,+      pc_OFFSET_StgRegTable_rHp :: Int,+      pc_OFFSET_StgRegTable_rHpLim :: Int,+      pc_OFFSET_StgRegTable_rCCCS :: Int,+      pc_OFFSET_StgRegTable_rCurrentTSO :: Int,+      pc_OFFSET_StgRegTable_rCurrentNursery :: Int,+      pc_OFFSET_StgRegTable_rHpAlloc :: Int,+      pc_OFFSET_stgEagerBlackholeInfo :: Int,+      pc_OFFSET_stgGCEnter1 :: Int,+      pc_OFFSET_stgGCFun :: Int,+      pc_OFFSET_Capability_r :: Int,+      pc_OFFSET_bdescr_start :: Int,+      pc_OFFSET_bdescr_free :: Int,+      pc_OFFSET_bdescr_blocks :: Int,+      pc_OFFSET_bdescr_flags :: Int,+      pc_SIZEOF_CostCentreStack :: Int,+      pc_OFFSET_CostCentreStack_mem_alloc :: Int,+      pc_REP_CostCentreStack_mem_alloc :: Int,+      pc_OFFSET_CostCentreStack_scc_count :: Int,+      pc_REP_CostCentreStack_scc_count :: Int,+      pc_OFFSET_StgHeader_ccs :: Int,+      pc_OFFSET_StgHeader_ldvw :: Int,+      pc_SIZEOF_StgSMPThunkHeader :: Int,+      pc_OFFSET_StgEntCounter_allocs :: Int,+      pc_REP_StgEntCounter_allocs :: Int,+      pc_OFFSET_StgEntCounter_allocd :: Int,+      pc_REP_StgEntCounter_allocd :: Int,+      pc_OFFSET_StgEntCounter_registeredp :: Int,+      pc_OFFSET_StgEntCounter_link :: Int,+      pc_OFFSET_StgEntCounter_entry_count :: Int,+      pc_SIZEOF_StgUpdateFrame_NoHdr :: Int,+      pc_SIZEOF_StgMutArrPtrs_NoHdr :: Int,+      pc_OFFSET_StgMutArrPtrs_ptrs :: Int,+      pc_OFFSET_StgMutArrPtrs_size :: Int,+      pc_SIZEOF_StgSmallMutArrPtrs_NoHdr :: Int,+      pc_OFFSET_StgSmallMutArrPtrs_ptrs :: Int,+      pc_SIZEOF_StgArrBytes_NoHdr :: Int,+      pc_OFFSET_StgArrBytes_bytes :: Int,+      pc_OFFSET_StgTSO_alloc_limit :: Int,+      pc_OFFSET_StgTSO_cccs :: Int,+      pc_OFFSET_StgTSO_stackobj :: Int,+      pc_OFFSET_StgStack_sp :: Int,+      pc_OFFSET_StgStack_stack :: Int,+      pc_OFFSET_StgUpdateFrame_updatee :: Int,+      pc_OFFSET_StgFunInfoExtraFwd_arity :: Int,+      pc_REP_StgFunInfoExtraFwd_arity :: Int,+      pc_SIZEOF_StgFunInfoExtraRev :: Int,+      pc_OFFSET_StgFunInfoExtraRev_arity :: Int,+      pc_REP_StgFunInfoExtraRev_arity :: Int,+      pc_MAX_SPEC_SELECTEE_SIZE :: Int,+      pc_MAX_SPEC_AP_SIZE :: Int,+      pc_MIN_PAYLOAD_SIZE :: Int,+      pc_MIN_INTLIKE :: Int,+      pc_MAX_INTLIKE :: Int,+      pc_MIN_CHARLIKE :: Int,+      pc_MAX_CHARLIKE :: Int,+      pc_MUT_ARR_PTRS_CARD_BITS :: Int,+      pc_MAX_Vanilla_REG :: Int,+      pc_MAX_Float_REG :: Int,+      pc_MAX_Double_REG :: Int,+      pc_MAX_Long_REG :: Int,+      pc_MAX_XMM_REG :: Int,+      pc_MAX_Real_Vanilla_REG :: Int,+      pc_MAX_Real_Float_REG :: Int,+      pc_MAX_Real_Double_REG :: Int,+      pc_MAX_Real_XMM_REG :: Int,+      pc_MAX_Real_Long_REG :: Int,+      pc_RESERVED_C_STACK_BYTES :: Int,+      pc_RESERVED_STACK_WORDS :: Int,+      pc_AP_STACK_SPLIM :: Int,+      pc_WORD_SIZE :: Int,+      pc_DOUBLE_SIZE :: Int,+      pc_CINT_SIZE :: Int,+      pc_CLONG_SIZE :: Int,+      pc_CLONG_LONG_SIZE :: Int,+      pc_BITMAP_BITS_SHIFT :: Int,+      pc_TAG_BITS :: Int,+      pc_WORDS_BIGENDIAN :: Bool,+      pc_DYNAMIC_BY_DEFAULT :: Bool,+      pc_LDV_SHIFT :: Int,+      pc_ILDV_CREATE_MASK :: Integer,+      pc_ILDV_STATE_CREATE :: Integer,+      pc_ILDV_STATE_USE :: Integer+  } deriving Read
+ ghc-lib/stage0/lib/GHCConstantsHaskellWrappers.hs view
@@ -0,0 +1,250 @@+cONTROL_GROUP_CONST_291 :: DynFlags -> Int+cONTROL_GROUP_CONST_291 dflags = pc_CONTROL_GROUP_CONST_291 (platformConstants dflags)+sTD_HDR_SIZE :: DynFlags -> Int+sTD_HDR_SIZE dflags = pc_STD_HDR_SIZE (platformConstants dflags)+pROF_HDR_SIZE :: DynFlags -> Int+pROF_HDR_SIZE dflags = pc_PROF_HDR_SIZE (platformConstants dflags)+bLOCK_SIZE :: DynFlags -> Int+bLOCK_SIZE dflags = pc_BLOCK_SIZE (platformConstants dflags)+bLOCKS_PER_MBLOCK :: DynFlags -> Int+bLOCKS_PER_MBLOCK dflags = pc_BLOCKS_PER_MBLOCK (platformConstants dflags)+tICKY_BIN_COUNT :: DynFlags -> Int+tICKY_BIN_COUNT dflags = pc_TICKY_BIN_COUNT (platformConstants dflags)+oFFSET_StgRegTable_rR1 :: DynFlags -> Int+oFFSET_StgRegTable_rR1 dflags = pc_OFFSET_StgRegTable_rR1 (platformConstants dflags)+oFFSET_StgRegTable_rR2 :: DynFlags -> Int+oFFSET_StgRegTable_rR2 dflags = pc_OFFSET_StgRegTable_rR2 (platformConstants dflags)+oFFSET_StgRegTable_rR3 :: DynFlags -> Int+oFFSET_StgRegTable_rR3 dflags = pc_OFFSET_StgRegTable_rR3 (platformConstants dflags)+oFFSET_StgRegTable_rR4 :: DynFlags -> Int+oFFSET_StgRegTable_rR4 dflags = pc_OFFSET_StgRegTable_rR4 (platformConstants dflags)+oFFSET_StgRegTable_rR5 :: DynFlags -> Int+oFFSET_StgRegTable_rR5 dflags = pc_OFFSET_StgRegTable_rR5 (platformConstants dflags)+oFFSET_StgRegTable_rR6 :: DynFlags -> Int+oFFSET_StgRegTable_rR6 dflags = pc_OFFSET_StgRegTable_rR6 (platformConstants dflags)+oFFSET_StgRegTable_rR7 :: DynFlags -> Int+oFFSET_StgRegTable_rR7 dflags = pc_OFFSET_StgRegTable_rR7 (platformConstants dflags)+oFFSET_StgRegTable_rR8 :: DynFlags -> Int+oFFSET_StgRegTable_rR8 dflags = pc_OFFSET_StgRegTable_rR8 (platformConstants dflags)+oFFSET_StgRegTable_rR9 :: DynFlags -> Int+oFFSET_StgRegTable_rR9 dflags = pc_OFFSET_StgRegTable_rR9 (platformConstants dflags)+oFFSET_StgRegTable_rR10 :: DynFlags -> Int+oFFSET_StgRegTable_rR10 dflags = pc_OFFSET_StgRegTable_rR10 (platformConstants dflags)+oFFSET_StgRegTable_rF1 :: DynFlags -> Int+oFFSET_StgRegTable_rF1 dflags = pc_OFFSET_StgRegTable_rF1 (platformConstants dflags)+oFFSET_StgRegTable_rF2 :: DynFlags -> Int+oFFSET_StgRegTable_rF2 dflags = pc_OFFSET_StgRegTable_rF2 (platformConstants dflags)+oFFSET_StgRegTable_rF3 :: DynFlags -> Int+oFFSET_StgRegTable_rF3 dflags = pc_OFFSET_StgRegTable_rF3 (platformConstants dflags)+oFFSET_StgRegTable_rF4 :: DynFlags -> Int+oFFSET_StgRegTable_rF4 dflags = pc_OFFSET_StgRegTable_rF4 (platformConstants dflags)+oFFSET_StgRegTable_rF5 :: DynFlags -> Int+oFFSET_StgRegTable_rF5 dflags = pc_OFFSET_StgRegTable_rF5 (platformConstants dflags)+oFFSET_StgRegTable_rF6 :: DynFlags -> Int+oFFSET_StgRegTable_rF6 dflags = pc_OFFSET_StgRegTable_rF6 (platformConstants dflags)+oFFSET_StgRegTable_rD1 :: DynFlags -> Int+oFFSET_StgRegTable_rD1 dflags = pc_OFFSET_StgRegTable_rD1 (platformConstants dflags)+oFFSET_StgRegTable_rD2 :: DynFlags -> Int+oFFSET_StgRegTable_rD2 dflags = pc_OFFSET_StgRegTable_rD2 (platformConstants dflags)+oFFSET_StgRegTable_rD3 :: DynFlags -> Int+oFFSET_StgRegTable_rD3 dflags = pc_OFFSET_StgRegTable_rD3 (platformConstants dflags)+oFFSET_StgRegTable_rD4 :: DynFlags -> Int+oFFSET_StgRegTable_rD4 dflags = pc_OFFSET_StgRegTable_rD4 (platformConstants dflags)+oFFSET_StgRegTable_rD5 :: DynFlags -> Int+oFFSET_StgRegTable_rD5 dflags = pc_OFFSET_StgRegTable_rD5 (platformConstants dflags)+oFFSET_StgRegTable_rD6 :: DynFlags -> Int+oFFSET_StgRegTable_rD6 dflags = pc_OFFSET_StgRegTable_rD6 (platformConstants dflags)+oFFSET_StgRegTable_rXMM1 :: DynFlags -> Int+oFFSET_StgRegTable_rXMM1 dflags = pc_OFFSET_StgRegTable_rXMM1 (platformConstants dflags)+oFFSET_StgRegTable_rXMM2 :: DynFlags -> Int+oFFSET_StgRegTable_rXMM2 dflags = pc_OFFSET_StgRegTable_rXMM2 (platformConstants dflags)+oFFSET_StgRegTable_rXMM3 :: DynFlags -> Int+oFFSET_StgRegTable_rXMM3 dflags = pc_OFFSET_StgRegTable_rXMM3 (platformConstants dflags)+oFFSET_StgRegTable_rXMM4 :: DynFlags -> Int+oFFSET_StgRegTable_rXMM4 dflags = pc_OFFSET_StgRegTable_rXMM4 (platformConstants dflags)+oFFSET_StgRegTable_rXMM5 :: DynFlags -> Int+oFFSET_StgRegTable_rXMM5 dflags = pc_OFFSET_StgRegTable_rXMM5 (platformConstants dflags)+oFFSET_StgRegTable_rXMM6 :: DynFlags -> Int+oFFSET_StgRegTable_rXMM6 dflags = pc_OFFSET_StgRegTable_rXMM6 (platformConstants dflags)+oFFSET_StgRegTable_rYMM1 :: DynFlags -> Int+oFFSET_StgRegTable_rYMM1 dflags = pc_OFFSET_StgRegTable_rYMM1 (platformConstants dflags)+oFFSET_StgRegTable_rYMM2 :: DynFlags -> Int+oFFSET_StgRegTable_rYMM2 dflags = pc_OFFSET_StgRegTable_rYMM2 (platformConstants dflags)+oFFSET_StgRegTable_rYMM3 :: DynFlags -> Int+oFFSET_StgRegTable_rYMM3 dflags = pc_OFFSET_StgRegTable_rYMM3 (platformConstants dflags)+oFFSET_StgRegTable_rYMM4 :: DynFlags -> Int+oFFSET_StgRegTable_rYMM4 dflags = pc_OFFSET_StgRegTable_rYMM4 (platformConstants dflags)+oFFSET_StgRegTable_rYMM5 :: DynFlags -> Int+oFFSET_StgRegTable_rYMM5 dflags = pc_OFFSET_StgRegTable_rYMM5 (platformConstants dflags)+oFFSET_StgRegTable_rYMM6 :: DynFlags -> Int+oFFSET_StgRegTable_rYMM6 dflags = pc_OFFSET_StgRegTable_rYMM6 (platformConstants dflags)+oFFSET_StgRegTable_rZMM1 :: DynFlags -> Int+oFFSET_StgRegTable_rZMM1 dflags = pc_OFFSET_StgRegTable_rZMM1 (platformConstants dflags)+oFFSET_StgRegTable_rZMM2 :: DynFlags -> Int+oFFSET_StgRegTable_rZMM2 dflags = pc_OFFSET_StgRegTable_rZMM2 (platformConstants dflags)+oFFSET_StgRegTable_rZMM3 :: DynFlags -> Int+oFFSET_StgRegTable_rZMM3 dflags = pc_OFFSET_StgRegTable_rZMM3 (platformConstants dflags)+oFFSET_StgRegTable_rZMM4 :: DynFlags -> Int+oFFSET_StgRegTable_rZMM4 dflags = pc_OFFSET_StgRegTable_rZMM4 (platformConstants dflags)+oFFSET_StgRegTable_rZMM5 :: DynFlags -> Int+oFFSET_StgRegTable_rZMM5 dflags = pc_OFFSET_StgRegTable_rZMM5 (platformConstants dflags)+oFFSET_StgRegTable_rZMM6 :: DynFlags -> Int+oFFSET_StgRegTable_rZMM6 dflags = pc_OFFSET_StgRegTable_rZMM6 (platformConstants dflags)+oFFSET_StgRegTable_rL1 :: DynFlags -> Int+oFFSET_StgRegTable_rL1 dflags = pc_OFFSET_StgRegTable_rL1 (platformConstants dflags)+oFFSET_StgRegTable_rSp :: DynFlags -> Int+oFFSET_StgRegTable_rSp dflags = pc_OFFSET_StgRegTable_rSp (platformConstants dflags)+oFFSET_StgRegTable_rSpLim :: DynFlags -> Int+oFFSET_StgRegTable_rSpLim dflags = pc_OFFSET_StgRegTable_rSpLim (platformConstants dflags)+oFFSET_StgRegTable_rHp :: DynFlags -> Int+oFFSET_StgRegTable_rHp dflags = pc_OFFSET_StgRegTable_rHp (platformConstants dflags)+oFFSET_StgRegTable_rHpLim :: DynFlags -> Int+oFFSET_StgRegTable_rHpLim dflags = pc_OFFSET_StgRegTable_rHpLim (platformConstants dflags)+oFFSET_StgRegTable_rCCCS :: DynFlags -> Int+oFFSET_StgRegTable_rCCCS dflags = pc_OFFSET_StgRegTable_rCCCS (platformConstants dflags)+oFFSET_StgRegTable_rCurrentTSO :: DynFlags -> Int+oFFSET_StgRegTable_rCurrentTSO dflags = pc_OFFSET_StgRegTable_rCurrentTSO (platformConstants dflags)+oFFSET_StgRegTable_rCurrentNursery :: DynFlags -> Int+oFFSET_StgRegTable_rCurrentNursery dflags = pc_OFFSET_StgRegTable_rCurrentNursery (platformConstants dflags)+oFFSET_StgRegTable_rHpAlloc :: DynFlags -> Int+oFFSET_StgRegTable_rHpAlloc dflags = pc_OFFSET_StgRegTable_rHpAlloc (platformConstants dflags)+oFFSET_stgEagerBlackholeInfo :: DynFlags -> Int+oFFSET_stgEagerBlackholeInfo dflags = pc_OFFSET_stgEagerBlackholeInfo (platformConstants dflags)+oFFSET_stgGCEnter1 :: DynFlags -> Int+oFFSET_stgGCEnter1 dflags = pc_OFFSET_stgGCEnter1 (platformConstants dflags)+oFFSET_stgGCFun :: DynFlags -> Int+oFFSET_stgGCFun dflags = pc_OFFSET_stgGCFun (platformConstants dflags)+oFFSET_Capability_r :: DynFlags -> Int+oFFSET_Capability_r dflags = pc_OFFSET_Capability_r (platformConstants dflags)+oFFSET_bdescr_start :: DynFlags -> Int+oFFSET_bdescr_start dflags = pc_OFFSET_bdescr_start (platformConstants dflags)+oFFSET_bdescr_free :: DynFlags -> Int+oFFSET_bdescr_free dflags = pc_OFFSET_bdescr_free (platformConstants dflags)+oFFSET_bdescr_blocks :: DynFlags -> Int+oFFSET_bdescr_blocks dflags = pc_OFFSET_bdescr_blocks (platformConstants dflags)+oFFSET_bdescr_flags :: DynFlags -> Int+oFFSET_bdescr_flags dflags = pc_OFFSET_bdescr_flags (platformConstants dflags)+sIZEOF_CostCentreStack :: DynFlags -> Int+sIZEOF_CostCentreStack dflags = pc_SIZEOF_CostCentreStack (platformConstants dflags)+oFFSET_CostCentreStack_mem_alloc :: DynFlags -> Int+oFFSET_CostCentreStack_mem_alloc dflags = pc_OFFSET_CostCentreStack_mem_alloc (platformConstants dflags)+oFFSET_CostCentreStack_scc_count :: DynFlags -> Int+oFFSET_CostCentreStack_scc_count dflags = pc_OFFSET_CostCentreStack_scc_count (platformConstants dflags)+oFFSET_StgHeader_ccs :: DynFlags -> Int+oFFSET_StgHeader_ccs dflags = pc_OFFSET_StgHeader_ccs (platformConstants dflags)+oFFSET_StgHeader_ldvw :: DynFlags -> Int+oFFSET_StgHeader_ldvw dflags = pc_OFFSET_StgHeader_ldvw (platformConstants dflags)+sIZEOF_StgSMPThunkHeader :: DynFlags -> Int+sIZEOF_StgSMPThunkHeader dflags = pc_SIZEOF_StgSMPThunkHeader (platformConstants dflags)+oFFSET_StgEntCounter_allocs :: DynFlags -> Int+oFFSET_StgEntCounter_allocs dflags = pc_OFFSET_StgEntCounter_allocs (platformConstants dflags)+oFFSET_StgEntCounter_allocd :: DynFlags -> Int+oFFSET_StgEntCounter_allocd dflags = pc_OFFSET_StgEntCounter_allocd (platformConstants dflags)+oFFSET_StgEntCounter_registeredp :: DynFlags -> Int+oFFSET_StgEntCounter_registeredp dflags = pc_OFFSET_StgEntCounter_registeredp (platformConstants dflags)+oFFSET_StgEntCounter_link :: DynFlags -> Int+oFFSET_StgEntCounter_link dflags = pc_OFFSET_StgEntCounter_link (platformConstants dflags)+oFFSET_StgEntCounter_entry_count :: DynFlags -> Int+oFFSET_StgEntCounter_entry_count dflags = pc_OFFSET_StgEntCounter_entry_count (platformConstants dflags)+sIZEOF_StgUpdateFrame_NoHdr :: DynFlags -> Int+sIZEOF_StgUpdateFrame_NoHdr dflags = pc_SIZEOF_StgUpdateFrame_NoHdr (platformConstants dflags)+sIZEOF_StgMutArrPtrs_NoHdr :: DynFlags -> Int+sIZEOF_StgMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgMutArrPtrs_NoHdr (platformConstants dflags)+oFFSET_StgMutArrPtrs_ptrs :: DynFlags -> Int+oFFSET_StgMutArrPtrs_ptrs dflags = pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants dflags)+oFFSET_StgMutArrPtrs_size :: DynFlags -> Int+oFFSET_StgMutArrPtrs_size dflags = pc_OFFSET_StgMutArrPtrs_size (platformConstants dflags)+sIZEOF_StgSmallMutArrPtrs_NoHdr :: DynFlags -> Int+sIZEOF_StgSmallMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgSmallMutArrPtrs_NoHdr (platformConstants dflags)+oFFSET_StgSmallMutArrPtrs_ptrs :: DynFlags -> Int+oFFSET_StgSmallMutArrPtrs_ptrs dflags = pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants dflags)+sIZEOF_StgArrBytes_NoHdr :: DynFlags -> Int+sIZEOF_StgArrBytes_NoHdr dflags = pc_SIZEOF_StgArrBytes_NoHdr (platformConstants dflags)+oFFSET_StgArrBytes_bytes :: DynFlags -> Int+oFFSET_StgArrBytes_bytes dflags = pc_OFFSET_StgArrBytes_bytes (platformConstants dflags)+oFFSET_StgTSO_alloc_limit :: DynFlags -> Int+oFFSET_StgTSO_alloc_limit dflags = pc_OFFSET_StgTSO_alloc_limit (platformConstants dflags)+oFFSET_StgTSO_cccs :: DynFlags -> Int+oFFSET_StgTSO_cccs dflags = pc_OFFSET_StgTSO_cccs (platformConstants dflags)+oFFSET_StgTSO_stackobj :: DynFlags -> Int+oFFSET_StgTSO_stackobj dflags = pc_OFFSET_StgTSO_stackobj (platformConstants dflags)+oFFSET_StgStack_sp :: DynFlags -> Int+oFFSET_StgStack_sp dflags = pc_OFFSET_StgStack_sp (platformConstants dflags)+oFFSET_StgStack_stack :: DynFlags -> Int+oFFSET_StgStack_stack dflags = pc_OFFSET_StgStack_stack (platformConstants dflags)+oFFSET_StgUpdateFrame_updatee :: DynFlags -> Int+oFFSET_StgUpdateFrame_updatee dflags = pc_OFFSET_StgUpdateFrame_updatee (platformConstants dflags)+oFFSET_StgFunInfoExtraFwd_arity :: DynFlags -> Int+oFFSET_StgFunInfoExtraFwd_arity dflags = pc_OFFSET_StgFunInfoExtraFwd_arity (platformConstants dflags)+sIZEOF_StgFunInfoExtraRev :: DynFlags -> Int+sIZEOF_StgFunInfoExtraRev dflags = pc_SIZEOF_StgFunInfoExtraRev (platformConstants dflags)+oFFSET_StgFunInfoExtraRev_arity :: DynFlags -> Int+oFFSET_StgFunInfoExtraRev_arity dflags = pc_OFFSET_StgFunInfoExtraRev_arity (platformConstants dflags)+mAX_SPEC_SELECTEE_SIZE :: DynFlags -> Int+mAX_SPEC_SELECTEE_SIZE dflags = pc_MAX_SPEC_SELECTEE_SIZE (platformConstants dflags)+mAX_SPEC_AP_SIZE :: DynFlags -> Int+mAX_SPEC_AP_SIZE dflags = pc_MAX_SPEC_AP_SIZE (platformConstants dflags)+mIN_PAYLOAD_SIZE :: DynFlags -> Int+mIN_PAYLOAD_SIZE dflags = pc_MIN_PAYLOAD_SIZE (platformConstants dflags)+mIN_INTLIKE :: DynFlags -> Int+mIN_INTLIKE dflags = pc_MIN_INTLIKE (platformConstants dflags)+mAX_INTLIKE :: DynFlags -> Int+mAX_INTLIKE dflags = pc_MAX_INTLIKE (platformConstants dflags)+mIN_CHARLIKE :: DynFlags -> Int+mIN_CHARLIKE dflags = pc_MIN_CHARLIKE (platformConstants dflags)+mAX_CHARLIKE :: DynFlags -> Int+mAX_CHARLIKE dflags = pc_MAX_CHARLIKE (platformConstants dflags)+mUT_ARR_PTRS_CARD_BITS :: DynFlags -> Int+mUT_ARR_PTRS_CARD_BITS dflags = pc_MUT_ARR_PTRS_CARD_BITS (platformConstants dflags)+mAX_Vanilla_REG :: DynFlags -> Int+mAX_Vanilla_REG dflags = pc_MAX_Vanilla_REG (platformConstants dflags)+mAX_Float_REG :: DynFlags -> Int+mAX_Float_REG dflags = pc_MAX_Float_REG (platformConstants dflags)+mAX_Double_REG :: DynFlags -> Int+mAX_Double_REG dflags = pc_MAX_Double_REG (platformConstants dflags)+mAX_Long_REG :: DynFlags -> Int+mAX_Long_REG dflags = pc_MAX_Long_REG (platformConstants dflags)+mAX_XMM_REG :: DynFlags -> Int+mAX_XMM_REG dflags = pc_MAX_XMM_REG (platformConstants dflags)+mAX_Real_Vanilla_REG :: DynFlags -> Int+mAX_Real_Vanilla_REG dflags = pc_MAX_Real_Vanilla_REG (platformConstants dflags)+mAX_Real_Float_REG :: DynFlags -> Int+mAX_Real_Float_REG dflags = pc_MAX_Real_Float_REG (platformConstants dflags)+mAX_Real_Double_REG :: DynFlags -> Int+mAX_Real_Double_REG dflags = pc_MAX_Real_Double_REG (platformConstants dflags)+mAX_Real_XMM_REG :: DynFlags -> Int+mAX_Real_XMM_REG dflags = pc_MAX_Real_XMM_REG (platformConstants dflags)+mAX_Real_Long_REG :: DynFlags -> Int+mAX_Real_Long_REG dflags = pc_MAX_Real_Long_REG (platformConstants dflags)+rESERVED_C_STACK_BYTES :: DynFlags -> Int+rESERVED_C_STACK_BYTES dflags = pc_RESERVED_C_STACK_BYTES (platformConstants dflags)+rESERVED_STACK_WORDS :: DynFlags -> Int+rESERVED_STACK_WORDS dflags = pc_RESERVED_STACK_WORDS (platformConstants dflags)+aP_STACK_SPLIM :: DynFlags -> Int+aP_STACK_SPLIM dflags = pc_AP_STACK_SPLIM (platformConstants dflags)+wORD_SIZE :: DynFlags -> Int+wORD_SIZE dflags = pc_WORD_SIZE (platformConstants dflags)+dOUBLE_SIZE :: DynFlags -> Int+dOUBLE_SIZE dflags = pc_DOUBLE_SIZE (platformConstants dflags)+cINT_SIZE :: DynFlags -> Int+cINT_SIZE dflags = pc_CINT_SIZE (platformConstants dflags)+cLONG_SIZE :: DynFlags -> Int+cLONG_SIZE dflags = pc_CLONG_SIZE (platformConstants dflags)+cLONG_LONG_SIZE :: DynFlags -> Int+cLONG_LONG_SIZE dflags = pc_CLONG_LONG_SIZE (platformConstants dflags)+bITMAP_BITS_SHIFT :: DynFlags -> Int+bITMAP_BITS_SHIFT dflags = pc_BITMAP_BITS_SHIFT (platformConstants dflags)+tAG_BITS :: DynFlags -> Int+tAG_BITS dflags = pc_TAG_BITS (platformConstants dflags)+wORDS_BIGENDIAN :: DynFlags -> Bool+wORDS_BIGENDIAN dflags = pc_WORDS_BIGENDIAN (platformConstants dflags)+dYNAMIC_BY_DEFAULT :: DynFlags -> Bool+dYNAMIC_BY_DEFAULT dflags = pc_DYNAMIC_BY_DEFAULT (platformConstants dflags)+lDV_SHIFT :: DynFlags -> Int+lDV_SHIFT dflags = pc_LDV_SHIFT (platformConstants dflags)+iLDV_CREATE_MASK :: DynFlags -> Integer+iLDV_CREATE_MASK dflags = pc_ILDV_CREATE_MASK (platformConstants dflags)+iLDV_STATE_CREATE :: DynFlags -> Integer+iLDV_STATE_CREATE dflags = pc_ILDV_STATE_CREATE (platformConstants dflags)+iLDV_STATE_USE :: DynFlags -> Integer+iLDV_STATE_USE dflags = pc_ILDV_STATE_USE (platformConstants dflags)
+ ghc-lib/stage0/lib/ghcautoconf.h view
@@ -0,0 +1,545 @@+#if !defined(__GHCAUTOCONF_H__)+#define __GHCAUTOCONF_H__+/* mk/config.h.  Generated from config.h.in by configure.  */+/* mk/config.h.in.  Generated from configure.ac by autoheader.  */++/* Define if building universal (internal helper macro) */+/* #undef AC_APPLE_UNIVERSAL_BUILD */++/* The alignment of a `char'. */+#define ALIGNMENT_CHAR 1++/* The alignment of a `double'. */+#define ALIGNMENT_DOUBLE 8++/* The alignment of a `float'. */+#define ALIGNMENT_FLOAT 4++/* The alignment of a `int'. */+#define ALIGNMENT_INT 4++/* The alignment of a `int16_t'. */+#define ALIGNMENT_INT16_T 2++/* The alignment of a `int32_t'. */+#define ALIGNMENT_INT32_T 4++/* The alignment of a `int64_t'. */+#define ALIGNMENT_INT64_T 8++/* The alignment of a `int8_t'. */+#define ALIGNMENT_INT8_T 1++/* The alignment of a `long'. */+#define ALIGNMENT_LONG 8++/* The alignment of a `long long'. */+#define ALIGNMENT_LONG_LONG 8++/* The alignment of a `short'. */+#define ALIGNMENT_SHORT 2++/* The alignment of a `uint16_t'. */+#define ALIGNMENT_UINT16_T 2++/* The alignment of a `uint32_t'. */+#define ALIGNMENT_UINT32_T 4++/* The alignment of a `uint64_t'. */+#define ALIGNMENT_UINT64_T 8++/* The alignment of a `uint8_t'. */+#define ALIGNMENT_UINT8_T 1++/* The alignment of a `unsigned char'. */+#define ALIGNMENT_UNSIGNED_CHAR 1++/* The alignment of a `unsigned int'. */+#define ALIGNMENT_UNSIGNED_INT 4++/* The alignment of a `unsigned long'. */+#define ALIGNMENT_UNSIGNED_LONG 8++/* The alignment of a `unsigned long long'. */+#define ALIGNMENT_UNSIGNED_LONG_LONG 8++/* The alignment of a `unsigned short'. */+#define ALIGNMENT_UNSIGNED_SHORT 2++/* The alignment of a `void *'. */+#define ALIGNMENT_VOID_P 8++/* Define (to 1) if C compiler has an LLVM back end */+#define CC_LLVM_BACKEND 1++/* Define to 1 if __thread is supported */+#define CC_SUPPORTS_TLS 1++/* Define to one of `_getb67', `GETB67', `getb67' for Cray-2 and Cray-YMP+   systems. This function is required for `alloca.c' support on those systems.+   */+/* #undef CRAY_STACKSEG_END */++/* Define to 1 if using `alloca.c'. */+/* #undef C_ALLOCA */++/* Define to 1 if your processor stores words of floats with the most+   significant byte first */+/* #undef FLOAT_WORDS_BIGENDIAN */++/* Has visibility hidden */+#define HAS_VISIBILITY_HIDDEN 1++/* Define to 1 if you have `alloca', as a function or macro. */+#define HAVE_ALLOCA 1++/* Define to 1 if you have <alloca.h> and it should be used (not on Ultrix).+   */+#define HAVE_ALLOCA_H 1++/* Define to 1 if you have the <bfd.h> header file. */+/* #undef HAVE_BFD_H */++/* Does GCC support __atomic primitives? */+#define HAVE_C11_ATOMICS 1++/* Define to 1 if you have the `clock_gettime' function. */+#define HAVE_CLOCK_GETTIME 1++/* Define to 1 if you have the `ctime_r' function. */+#define HAVE_CTIME_R 1++/* Define to 1 if you have the <ctype.h> header file. */+#define HAVE_CTYPE_H 1++/* Define to 1 if you have the declaration of `ctime_r', and to 0 if you+   don't. */+#define HAVE_DECL_CTIME_R 1++/* Define to 1 if you have the declaration of `MADV_DONTNEED', and to 0 if you+   don't. */+/* #undef HAVE_DECL_MADV_DONTNEED */++/* Define to 1 if you have the declaration of `MADV_FREE', and to 0 if you+   don't. */+/* #undef HAVE_DECL_MADV_FREE */++/* Define to 1 if you have the declaration of `MAP_NORESERVE', and to 0 if you+   don't. */+/* #undef HAVE_DECL_MAP_NORESERVE */++/* Define to 1 if you have the <dirent.h> header file. */+#define HAVE_DIRENT_H 1++/* Define to 1 if you have the <dlfcn.h> header file. */+#define HAVE_DLFCN_H 1++/* Define to 1 if you have the <elfutils/libdw.h> header file. */+/* #undef HAVE_ELFUTILS_LIBDW_H */++/* Define to 1 if you have the <errno.h> header file. */+#define HAVE_ERRNO_H 1++/* Define to 1 if you have the `eventfd' function. */+/* #undef HAVE_EVENTFD */++/* Define to 1 if you have the <fcntl.h> header file. */+#define HAVE_FCNTL_H 1++/* Define to 1 if you have the <ffi.h> header file. */+/* #undef HAVE_FFI_H */++/* Define to 1 if you have the `fork' function. */+#define HAVE_FORK 1++/* Define to 1 if you have the `getclock' function. */+/* #undef HAVE_GETCLOCK */++/* Define to 1 if you have the `GetModuleFileName' function. */+/* #undef HAVE_GETMODULEFILENAME */++/* Define to 1 if you have the `getrusage' function. */+#define HAVE_GETRUSAGE 1++/* Define to 1 if you have the `gettimeofday' function. */+#define HAVE_GETTIMEOFDAY 1++/* Define to 1 if you have the <grp.h> header file. */+#define HAVE_GRP_H 1++/* Define to 1 if you have the <inttypes.h> header file. */+#define HAVE_INTTYPES_H 1++/* Define to 1 if you have the `bfd' library (-lbfd). */+/* #undef HAVE_LIBBFD */++/* Define to 1 if you have the `dl' library (-ldl). */+#define HAVE_LIBDL 1++/* Define to 1 if you have libffi. */+/* #undef HAVE_LIBFFI */++/* Define to 1 if you have the `iberty' library (-liberty). */+/* #undef HAVE_LIBIBERTY */++/* Define to 1 if you need to link with libm */+#define HAVE_LIBM 1++/* Define to 1 if you have libnuma */+#define HAVE_LIBNUMA 0++/* Define to 1 if you have the `pthread' library (-lpthread). */+#define HAVE_LIBPTHREAD 1++/* Define to 1 if you have the `rt' library (-lrt). */+/* #undef HAVE_LIBRT */++/* Define to 1 if you have the <limits.h> header file. */+#define HAVE_LIMITS_H 1++/* Define to 1 if you have the <locale.h> header file. */+#define HAVE_LOCALE_H 1++/* Define to 1 if the system has the type `long long'. */+#define HAVE_LONG_LONG 1++/* Define to 1 if you have the <memory.h> header file. */+#define HAVE_MEMORY_H 1++/* Define to 1 if you have the mingwex library. */+/* #undef HAVE_MINGWEX */++/* Define to 1 if you have the <nlist.h> header file. */+#define HAVE_NLIST_H 1++/* Define to 1 if you have the <numaif.h> header file. */+/* #undef HAVE_NUMAIF_H */++/* Define to 1 if you have the <numa.h> header file. */+/* #undef HAVE_NUMA_H */++/* Define to 1 if we have printf$LDBLStub (Apple Mac OS >= 10.4, PPC). */+#define HAVE_PRINTF_LDBLSTUB 0++/* Define to 1 if you have the <pthread.h> header file. */+#define HAVE_PTHREAD_H 1++/* Define to 1 if you have the glibc version of pthread_setname_np */+/* #undef HAVE_PTHREAD_SETNAME_NP */++/* Define to 1 if you have the <pwd.h> header file. */+#define HAVE_PWD_H 1++/* Define to 1 if you have the <sched.h> header file. */+#define HAVE_SCHED_H 1++/* Define to 1 if you have the `sched_setaffinity' function. */+/* #undef HAVE_SCHED_SETAFFINITY */++/* Define to 1 if you have the `setitimer' function. */+#define HAVE_SETITIMER 1++/* Define to 1 if you have the `setlocale' function. */+#define HAVE_SETLOCALE 1++/* Define to 1 if you have the `siginterrupt' function. */+#define HAVE_SIGINTERRUPT 1++/* Define to 1 if you have the <signal.h> header file. */+#define HAVE_SIGNAL_H 1++/* Define to 1 if you have the <stdint.h> header file. */+#define HAVE_STDINT_H 1++/* Define to 1 if you have the <stdlib.h> header file. */+#define HAVE_STDLIB_H 1++/* Define to 1 if you have the <strings.h> header file. */+#define HAVE_STRINGS_H 1++/* Define to 1 if you have the <string.h> header file. */+#define HAVE_STRING_H 1++/* Define to 1 if Apple-style dead-stripping is supported. */+#define HAVE_SUBSECTIONS_VIA_SYMBOLS 1++/* Define to 1 if you have the `sysconf' function. */+#define HAVE_SYSCONF 1++/* Define to 1 if you have the <sys/cpuset.h> header file. */+/* #undef HAVE_SYS_CPUSET_H */++/* Define to 1 if you have the <sys/eventfd.h> header file. */+/* #undef HAVE_SYS_EVENTFD_H */++/* Define to 1 if you have the <sys/mman.h> header file. */+#define HAVE_SYS_MMAN_H 1++/* Define to 1 if you have the <sys/param.h> header file. */+#define HAVE_SYS_PARAM_H 1++/* Define to 1 if you have the <sys/resource.h> header file. */+#define HAVE_SYS_RESOURCE_H 1++/* Define to 1 if you have the <sys/select.h> header file. */+#define HAVE_SYS_SELECT_H 1++/* Define to 1 if you have the <sys/stat.h> header file. */+#define HAVE_SYS_STAT_H 1++/* Define to 1 if you have the <sys/timeb.h> header file. */+#define HAVE_SYS_TIMEB_H 1++/* Define to 1 if you have the <sys/timerfd.h> header file. */+/* #undef HAVE_SYS_TIMERFD_H */++/* Define to 1 if you have the <sys/timers.h> header file. */+/* #undef HAVE_SYS_TIMERS_H */++/* Define to 1 if you have the <sys/times.h> header file. */+#define HAVE_SYS_TIMES_H 1++/* Define to 1 if you have the <sys/time.h> header file. */+#define HAVE_SYS_TIME_H 1++/* Define to 1 if you have the <sys/types.h> header file. */+#define HAVE_SYS_TYPES_H 1++/* Define to 1 if you have the <sys/utsname.h> header file. */+#define HAVE_SYS_UTSNAME_H 1++/* Define to 1 if you have the <sys/wait.h> header file. */+#define HAVE_SYS_WAIT_H 1++/* Define to 1 if you have the <termios.h> header file. */+#define HAVE_TERMIOS_H 1++/* Define to 1 if you have the `timer_settime' function. */+/* #undef HAVE_TIMER_SETTIME */++/* Define to 1 if you have the `times' function. */+#define HAVE_TIMES 1++/* Define to 1 if you have the <time.h> header file. */+#define HAVE_TIME_H 1++/* Define to 1 if you have the <unistd.h> header file. */+#define HAVE_UNISTD_H 1++/* Define to 1 if you have the <utime.h> header file. */+#define HAVE_UTIME_H 1++/* Define to 1 if you have the `vfork' function. */+#define HAVE_VFORK 1++/* Define to 1 if you have the <vfork.h> header file. */+/* #undef HAVE_VFORK_H */++/* Define to 1 if you have the <windows.h> header file. */+/* #undef HAVE_WINDOWS_H */++/* Define to 1 if you have the `WinExec' function. */+/* #undef HAVE_WINEXEC */++/* Define to 1 if you have the <winsock.h> header file. */+/* #undef HAVE_WINSOCK_H */++/* Define to 1 if `fork' works. */+#define HAVE_WORKING_FORK 1++/* Define to 1 if `vfork' works. */+#define HAVE_WORKING_VFORK 1++/* Define to 1 if C symbols have a leading underscore added by the compiler.+   */+#define LEADING_UNDERSCORE 1++/* Define 1 if we need to link code using pthreads with -lpthread */+#define NEED_PTHREAD_LIB 0++/* Define to the address where bug reports for this package should be sent. */+/* #undef PACKAGE_BUGREPORT */++/* Define to the full name of this package. */+/* #undef PACKAGE_NAME */++/* Define to the full name and version of this package. */+/* #undef PACKAGE_STRING */++/* Define to the one symbol short name of this package. */+/* #undef PACKAGE_TARNAME */++/* Define to the home page for this package. */+/* #undef PACKAGE_URL */++/* Define to the version of this package. */+/* #undef PACKAGE_VERSION */++/* Use mmap in the runtime linker */+#define RTS_LINKER_USE_MMAP 1++/* The size of `char', as computed by sizeof. */+#define SIZEOF_CHAR 1++/* The size of `double', as computed by sizeof. */+#define SIZEOF_DOUBLE 8++/* The size of `float', as computed by sizeof. */+#define SIZEOF_FLOAT 4++/* The size of `int', as computed by sizeof. */+#define SIZEOF_INT 4++/* The size of `int16_t', as computed by sizeof. */+#define SIZEOF_INT16_T 2++/* The size of `int32_t', as computed by sizeof. */+#define SIZEOF_INT32_T 4++/* The size of `int64_t', as computed by sizeof. */+#define SIZEOF_INT64_T 8++/* The size of `int8_t', as computed by sizeof. */+#define SIZEOF_INT8_T 1++/* The size of `long', as computed by sizeof. */+#define SIZEOF_LONG 8++/* The size of `long long', as computed by sizeof. */+#define SIZEOF_LONG_LONG 8++/* The size of `short', as computed by sizeof. */+#define SIZEOF_SHORT 2++/* The size of `uint16_t', as computed by sizeof. */+#define SIZEOF_UINT16_T 2++/* The size of `uint32_t', as computed by sizeof. */+#define SIZEOF_UINT32_T 4++/* The size of `uint64_t', as computed by sizeof. */+#define SIZEOF_UINT64_T 8++/* The size of `uint8_t', as computed by sizeof. */+#define SIZEOF_UINT8_T 1++/* The size of `unsigned char', as computed by sizeof. */+#define SIZEOF_UNSIGNED_CHAR 1++/* The size of `unsigned int', as computed by sizeof. */+#define SIZEOF_UNSIGNED_INT 4++/* The size of `unsigned long', as computed by sizeof. */+#define SIZEOF_UNSIGNED_LONG 8++/* The size of `unsigned long long', as computed by sizeof. */+#define SIZEOF_UNSIGNED_LONG_LONG 8++/* The size of `unsigned short', as computed by sizeof. */+#define SIZEOF_UNSIGNED_SHORT 2++/* The size of `void *', as computed by sizeof. */+#define SIZEOF_VOID_P 8++/* If using the C implementation of alloca, define if you know the+   direction of stack growth for your system; otherwise it will be+   automatically deduced at runtime.+	STACK_DIRECTION > 0 => grows toward higher addresses+	STACK_DIRECTION < 0 => grows toward lower addresses+	STACK_DIRECTION = 0 => direction of growth unknown */+/* #undef STACK_DIRECTION */++/* Define to 1 if you have the ANSI C header files. */+#define STDC_HEADERS 1++/* Define to 1 if info tables are layed out next to code */+#define TABLES_NEXT_TO_CODE 1++/* Define to 1 if you can safely include both <sys/time.h> and <time.h>. */+#define TIME_WITH_SYS_TIME 1++/* Enable single heap address space support */+#define USE_LARGE_ADDRESS_SPACE 1++/* Set to 1 to use libdw */+#define USE_LIBDW 0++/* Enable extensions on AIX 3, Interix.  */+#ifndef _ALL_SOURCE+# define _ALL_SOURCE 1+#endif+/* Enable GNU extensions on systems that have them.  */+#ifndef _GNU_SOURCE+# define _GNU_SOURCE 1+#endif+/* Enable threading extensions on Solaris.  */+#ifndef _POSIX_PTHREAD_SEMANTICS+# define _POSIX_PTHREAD_SEMANTICS 1+#endif+/* Enable extensions on HP NonStop.  */+#ifndef _TANDEM_SOURCE+# define _TANDEM_SOURCE 1+#endif+/* Enable general extensions on Solaris.  */+#ifndef __EXTENSIONS__+# define __EXTENSIONS__ 1+#endif+++/* Define to 1 if we can use timer_create(CLOCK_REALTIME,...) */+/* #undef USE_TIMER_CREATE */++/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most+   significant byte first (like Motorola and SPARC, unlike Intel). */+#if defined AC_APPLE_UNIVERSAL_BUILD+# if defined __BIG_ENDIAN__+#  define WORDS_BIGENDIAN 1+# endif+#else+# ifndef WORDS_BIGENDIAN+/* #  undef WORDS_BIGENDIAN */+# endif+#endif++/* Enable large inode numbers on Mac OS X 10.5.  */+#ifndef _DARWIN_USE_64_BIT_INODE+# define _DARWIN_USE_64_BIT_INODE 1+#endif++/* Number of bits in a file offset, on hosts where this is settable. */+/* #undef _FILE_OFFSET_BITS */++/* Define for large files, on AIX-style hosts. */+/* #undef _LARGE_FILES */++/* Define to 1 if on MINIX. */+/* #undef _MINIX */++/* Define to 2 if the system does not provide POSIX.1 features except with+   this defined. */+/* #undef _POSIX_1_SOURCE */++/* Define to 1 if you need to in order for `stat' and other things to work. */+/* #undef _POSIX_SOURCE */++/* ARM pre v6 */+/* #undef arm_HOST_ARCH_PRE_ARMv6 */++/* ARM pre v7 */+/* #undef arm_HOST_ARCH_PRE_ARMv7 */++/* Define to empty if `const' does not conform to ANSI C. */+/* #undef const */++/* Define to `int' if <sys/types.h> does not define. */+/* #undef pid_t */++/* The supported LLVM version number */+#define sUPPORTED_LLVM_VERSION (9)++/* Define to `unsigned int' if <sys/types.h> does not define. */+/* #undef size_t */++/* Define as `fork' if `vfork' does not work. */+/* #undef vfork */+#endif /* __GHCAUTOCONF_H__ */
+ ghc-lib/stage0/lib/ghcplatform.h view
@@ -0,0 +1,28 @@+#if !defined(__GHCPLATFORM_H__)+#define __GHCPLATFORM_H__++#define GHC_STAGE 1++#define BuildPlatform_TYPE  x86_64_apple_darwin+#define HostPlatform_TYPE   x86_64_apple_darwin++#define x86_64_apple_darwin_BUILD 1+#define x86_64_apple_darwin_HOST 1++#define x86_64_BUILD_ARCH 1+#define x86_64_HOST_ARCH 1+#define BUILD_ARCH "x86_64"+#define HOST_ARCH "x86_64"++#define darwin_BUILD_OS 1+#define darwin_HOST_OS 1+#define BUILD_OS "darwin"+#define HOST_OS "darwin"++#define apple_BUILD_VENDOR 1+#define apple_HOST_VENDOR 1+#define BUILD_VENDOR "apple"+#define HOST_VENDOR "apple"+++#endif /* __GHCPLATFORM_H__ */
+ ghc-lib/stage0/lib/ghcversion.h view
@@ -0,0 +1,18 @@+#if !defined(__GHCVERSION_H__)+#define __GHCVERSION_H__++#if !defined(__GLASGOW_HASKELL__)+# define __GLASGOW_HASKELL__ 810+#endif++#define __GLASGOW_HASKELL_PATCHLEVEL1__ 1++#define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\+   ((ma)*100+(mi)) <  __GLASGOW_HASKELL__ || \+   ((ma)*100+(mi)) == __GLASGOW_HASKELL__    \+          && (pl1) <  __GLASGOW_HASKELL_PATCHLEVEL1__ || \+   ((ma)*100+(mi)) == __GLASGOW_HASKELL__    \+          && (pl1) == __GLASGOW_HASKELL_PATCHLEVEL1__ \+          && (pl2) <= __GLASGOW_HASKELL_PATCHLEVEL2__ )++#endif /* __GHCVERSION_H__ */
ghc-lib/stage0/lib/llvm-targets view
@@ -1,25 +1,39 @@ [("i386-unknown-windows", ("e-m:x-p:32:32-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", "")) ,("i686-unknown-windows", ("e-m:x-p:32:32-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", "")) ,("x86_64-unknown-windows", ("e-m:w-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))-,("arm-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))-,("armv6-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+strict-align"))-,("armv6l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))-,("armv7-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7a-unknown-linux-gnueabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7a-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7l-unknown-linux-gnueabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("arm-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))+,("arm-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))+,("armv6-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+strict-align"))+,("armv6-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+strict-align"))+,("armv6l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))+,("armv6l-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))+,("armv7-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7a-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7a-unknown-linux-musleabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7a-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7a-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7l-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7l-unknown-linux-musleabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7l-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) ,("aarch64-unknown-linux-gnu", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))+,("aarch64-unknown-linux-musl", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) ,("aarch64-unknown-linux", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) ,("i386-unknown-linux-gnu", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", ""))+,("i386-unknown-linux-musl", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", "")) ,("i386-unknown-linux", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", "")) ,("x86_64-unknown-linux-gnu", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))+,("x86_64-unknown-linux-musl", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("x86_64-unknown-linux", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))-,("x86_64-unknown-linux-android", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "+sse4.2 +popcnt"))-,("armv7-unknown-linux-androideabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("x86_64-unknown-linux-android", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "+sse4.2 +popcnt +cx16"))+,("armv7-unknown-linux-androideabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+fpregs +vfp2 +vfp2d16 +vfp2d16sp +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -crypto -fp16fml")) ,("aarch64-unknown-linux-android", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))-,("armv7a-unknown-linux-androideabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7a-unknown-linux-androideabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+fpregs +vfp2 +vfp2d16 +vfp2d16sp +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -crypto -fp16fml"))+,("powerpc64le-unknown-linux-gnu", ("e-m:e-i64:64-n32:64", "ppc64le", ""))+,("powerpc64le-unknown-linux-musl", ("e-m:e-i64:64-n32:64", "ppc64le", "+secure-plt")) ,("powerpc64le-unknown-linux", ("e-m:e-i64:64-n32:64", "ppc64le", ""))+,("s390x-ibm-linux", ("E-m:e-i1:8:16-i8:8:16-i64:64-f128:64-a:8:16-n32:64", "z10", "")) ,("i386-apple-darwin", ("e-m:o-p:32:32-f64:32:64-f80:128-n8:16:32-S128", "yonah", "")) ,("x86_64-apple-darwin", ("e-m:o-i64:64-f80:128-n8:16:32:64-S128", "core2", "")) ,("armv7-apple-ios", ("e-m:o-p:32:32-f64:32:64-v64:32:64-v128:32:128-a:0:32-n32-S32", "generic", ""))@@ -29,7 +43,7 @@ ,("amd64-portbld-freebsd", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("x86_64-unknown-freebsd", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("aarch64-unknown-freebsd", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))-,("armv6-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))-,("armv7-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+strict-align"))-,("arm-unknown-nto-qnx-eabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align"))+,("armv6-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))+,("armv7-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+strict-align"))+,("arm-unknown-nto-qnx-eabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align")) ]
ghc-lib/stage0/lib/platformConstants view
@@ -1,134 +1,133 @@ PlatformConstants {-    pc_platformConstants = ()-    , pc_CONTROL_GROUP_CONST_291 = 291-    , pc_STD_HDR_SIZE = 1-    , pc_PROF_HDR_SIZE = 2-    , pc_BLOCK_SIZE = 4096-    , pc_BLOCKS_PER_MBLOCK = 252-    , pc_TICKY_BIN_COUNT = 9-    , pc_OFFSET_StgRegTable_rR1 = 0-    , pc_OFFSET_StgRegTable_rR2 = 8-    , pc_OFFSET_StgRegTable_rR3 = 16-    , pc_OFFSET_StgRegTable_rR4 = 24-    , pc_OFFSET_StgRegTable_rR5 = 32-    , pc_OFFSET_StgRegTable_rR6 = 40-    , pc_OFFSET_StgRegTable_rR7 = 48-    , pc_OFFSET_StgRegTable_rR8 = 56-    , pc_OFFSET_StgRegTable_rR9 = 64-    , pc_OFFSET_StgRegTable_rR10 = 72-    , pc_OFFSET_StgRegTable_rF1 = 80-    , pc_OFFSET_StgRegTable_rF2 = 84-    , pc_OFFSET_StgRegTable_rF3 = 88-    , pc_OFFSET_StgRegTable_rF4 = 92-    , pc_OFFSET_StgRegTable_rF5 = 96-    , pc_OFFSET_StgRegTable_rF6 = 100-    , pc_OFFSET_StgRegTable_rD1 = 104-    , pc_OFFSET_StgRegTable_rD2 = 112-    , pc_OFFSET_StgRegTable_rD3 = 120-    , pc_OFFSET_StgRegTable_rD4 = 128-    , pc_OFFSET_StgRegTable_rD5 = 136-    , pc_OFFSET_StgRegTable_rD6 = 144-    , pc_OFFSET_StgRegTable_rXMM1 = 152-    , pc_OFFSET_StgRegTable_rXMM2 = 168-    , pc_OFFSET_StgRegTable_rXMM3 = 184-    , pc_OFFSET_StgRegTable_rXMM4 = 200-    , pc_OFFSET_StgRegTable_rXMM5 = 216-    , pc_OFFSET_StgRegTable_rXMM6 = 232-    , pc_OFFSET_StgRegTable_rYMM1 = 248-    , pc_OFFSET_StgRegTable_rYMM2 = 280-    , pc_OFFSET_StgRegTable_rYMM3 = 312-    , pc_OFFSET_StgRegTable_rYMM4 = 344-    , pc_OFFSET_StgRegTable_rYMM5 = 376-    , pc_OFFSET_StgRegTable_rYMM6 = 408-    , pc_OFFSET_StgRegTable_rZMM1 = 440-    , pc_OFFSET_StgRegTable_rZMM2 = 504-    , pc_OFFSET_StgRegTable_rZMM3 = 568-    , pc_OFFSET_StgRegTable_rZMM4 = 632-    , pc_OFFSET_StgRegTable_rZMM5 = 696-    , pc_OFFSET_StgRegTable_rZMM6 = 760-    , pc_OFFSET_StgRegTable_rL1 = 824-    , pc_OFFSET_StgRegTable_rSp = 832-    , pc_OFFSET_StgRegTable_rSpLim = 840-    , pc_OFFSET_StgRegTable_rHp = 848-    , pc_OFFSET_StgRegTable_rHpLim = 856-    , pc_OFFSET_StgRegTable_rCCCS = 864-    , pc_OFFSET_StgRegTable_rCurrentTSO = 872-    , pc_OFFSET_StgRegTable_rCurrentNursery = 888-    , pc_OFFSET_StgRegTable_rHpAlloc = 904-    , pc_OFFSET_stgEagerBlackholeInfo = -24-    , pc_OFFSET_stgGCEnter1 = -16-    , pc_OFFSET_stgGCFun = -8-    , pc_OFFSET_Capability_r = 24-    , pc_OFFSET_bdescr_start = 0-    , pc_OFFSET_bdescr_free = 8-    , pc_OFFSET_bdescr_blocks = 48-    , pc_OFFSET_bdescr_flags = 46-    , pc_SIZEOF_CostCentreStack = 96-    , pc_OFFSET_CostCentreStack_mem_alloc = 72-    , pc_REP_CostCentreStack_mem_alloc = 8-    , pc_OFFSET_CostCentreStack_scc_count = 48-    , pc_REP_CostCentreStack_scc_count = 8-    , pc_OFFSET_StgHeader_ccs = 8-    , pc_OFFSET_StgHeader_ldvw = 16-    , pc_SIZEOF_StgSMPThunkHeader = 8-    , pc_OFFSET_StgEntCounter_allocs = 48-    , pc_REP_StgEntCounter_allocs = 8-    , pc_OFFSET_StgEntCounter_allocd = 16-    , pc_REP_StgEntCounter_allocd = 8-    , pc_OFFSET_StgEntCounter_registeredp = 0-    , pc_OFFSET_StgEntCounter_link = 56-    , pc_OFFSET_StgEntCounter_entry_count = 40-    , pc_SIZEOF_StgUpdateFrame_NoHdr = 8-    , pc_SIZEOF_StgMutArrPtrs_NoHdr = 16-    , pc_OFFSET_StgMutArrPtrs_ptrs = 0-    , pc_OFFSET_StgMutArrPtrs_size = 8-    , pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 8-    , pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0-    , pc_SIZEOF_StgArrBytes_NoHdr = 8-    , pc_OFFSET_StgArrBytes_bytes = 0-    , pc_OFFSET_StgTSO_alloc_limit = 96-    , pc_OFFSET_StgTSO_cccs = 112-    , pc_OFFSET_StgTSO_stackobj = 16-    , pc_OFFSET_StgStack_sp = 8-    , pc_OFFSET_StgStack_stack = 16-    , pc_OFFSET_StgUpdateFrame_updatee = 0-    , pc_OFFSET_StgFunInfoExtraFwd_arity = 4-    , pc_REP_StgFunInfoExtraFwd_arity = 4-    , pc_SIZEOF_StgFunInfoExtraRev = 24-    , pc_OFFSET_StgFunInfoExtraRev_arity = 20-    , pc_REP_StgFunInfoExtraRev_arity = 4-    , pc_MAX_SPEC_SELECTEE_SIZE = 15-    , pc_MAX_SPEC_AP_SIZE = 7-    , pc_MIN_PAYLOAD_SIZE = 1-    , pc_MIN_INTLIKE = -16-    , pc_MAX_INTLIKE = 16-    , pc_MIN_CHARLIKE = 0-    , pc_MAX_CHARLIKE = 255-    , pc_MUT_ARR_PTRS_CARD_BITS = 7-    , pc_MAX_Vanilla_REG = 10-    , pc_MAX_Float_REG = 6-    , pc_MAX_Double_REG = 6-    , pc_MAX_Long_REG = 1-    , pc_MAX_XMM_REG = 6-    , pc_MAX_Real_Vanilla_REG = 6-    , pc_MAX_Real_Float_REG = 6-    , pc_MAX_Real_Double_REG = 6-    , pc_MAX_Real_XMM_REG = 6-    , pc_MAX_Real_Long_REG = 0-    , pc_RESERVED_C_STACK_BYTES = 16384-    , pc_RESERVED_STACK_WORDS = 21-    , pc_AP_STACK_SPLIM = 1024-    , pc_WORD_SIZE = 8-    , pc_DOUBLE_SIZE = 8-    , pc_CINT_SIZE = 4-    , pc_CLONG_SIZE = 8-    , pc_CLONG_LONG_SIZE = 8-    , pc_BITMAP_BITS_SHIFT = 6-    , pc_TAG_BITS = 3-    , pc_WORDS_BIGENDIAN = False-    , pc_DYNAMIC_BY_DEFAULT = False-    , pc_LDV_SHIFT = 30-    , pc_ILDV_CREATE_MASK = 1152921503533105152-    , pc_ILDV_STATE_CREATE = 0-    , pc_ILDV_STATE_USE = 1152921504606846976+      pc_CONTROL_GROUP_CONST_291 = 291,+      pc_STD_HDR_SIZE = 1,+      pc_PROF_HDR_SIZE = 2,+      pc_BLOCK_SIZE = 4096,+      pc_BLOCKS_PER_MBLOCK = 252,+      pc_TICKY_BIN_COUNT = 9,+      pc_OFFSET_StgRegTable_rR1 = 0,+      pc_OFFSET_StgRegTable_rR2 = 8,+      pc_OFFSET_StgRegTable_rR3 = 16,+      pc_OFFSET_StgRegTable_rR4 = 24,+      pc_OFFSET_StgRegTable_rR5 = 32,+      pc_OFFSET_StgRegTable_rR6 = 40,+      pc_OFFSET_StgRegTable_rR7 = 48,+      pc_OFFSET_StgRegTable_rR8 = 56,+      pc_OFFSET_StgRegTable_rR9 = 64,+      pc_OFFSET_StgRegTable_rR10 = 72,+      pc_OFFSET_StgRegTable_rF1 = 80,+      pc_OFFSET_StgRegTable_rF2 = 84,+      pc_OFFSET_StgRegTable_rF3 = 88,+      pc_OFFSET_StgRegTable_rF4 = 92,+      pc_OFFSET_StgRegTable_rF5 = 96,+      pc_OFFSET_StgRegTable_rF6 = 100,+      pc_OFFSET_StgRegTable_rD1 = 104,+      pc_OFFSET_StgRegTable_rD2 = 112,+      pc_OFFSET_StgRegTable_rD3 = 120,+      pc_OFFSET_StgRegTable_rD4 = 128,+      pc_OFFSET_StgRegTable_rD5 = 136,+      pc_OFFSET_StgRegTable_rD6 = 144,+      pc_OFFSET_StgRegTable_rXMM1 = 152,+      pc_OFFSET_StgRegTable_rXMM2 = 168,+      pc_OFFSET_StgRegTable_rXMM3 = 184,+      pc_OFFSET_StgRegTable_rXMM4 = 200,+      pc_OFFSET_StgRegTable_rXMM5 = 216,+      pc_OFFSET_StgRegTable_rXMM6 = 232,+      pc_OFFSET_StgRegTable_rYMM1 = 248,+      pc_OFFSET_StgRegTable_rYMM2 = 280,+      pc_OFFSET_StgRegTable_rYMM3 = 312,+      pc_OFFSET_StgRegTable_rYMM4 = 344,+      pc_OFFSET_StgRegTable_rYMM5 = 376,+      pc_OFFSET_StgRegTable_rYMM6 = 408,+      pc_OFFSET_StgRegTable_rZMM1 = 440,+      pc_OFFSET_StgRegTable_rZMM2 = 504,+      pc_OFFSET_StgRegTable_rZMM3 = 568,+      pc_OFFSET_StgRegTable_rZMM4 = 632,+      pc_OFFSET_StgRegTable_rZMM5 = 696,+      pc_OFFSET_StgRegTable_rZMM6 = 760,+      pc_OFFSET_StgRegTable_rL1 = 824,+      pc_OFFSET_StgRegTable_rSp = 832,+      pc_OFFSET_StgRegTable_rSpLim = 840,+      pc_OFFSET_StgRegTable_rHp = 848,+      pc_OFFSET_StgRegTable_rHpLim = 856,+      pc_OFFSET_StgRegTable_rCCCS = 864,+      pc_OFFSET_StgRegTable_rCurrentTSO = 872,+      pc_OFFSET_StgRegTable_rCurrentNursery = 888,+      pc_OFFSET_StgRegTable_rHpAlloc = 904,+      pc_OFFSET_stgEagerBlackholeInfo = -24,+      pc_OFFSET_stgGCEnter1 = -16,+      pc_OFFSET_stgGCFun = -8,+      pc_OFFSET_Capability_r = 24,+      pc_OFFSET_bdescr_start = 0,+      pc_OFFSET_bdescr_free = 8,+      pc_OFFSET_bdescr_blocks = 48,+      pc_OFFSET_bdescr_flags = 46,+      pc_SIZEOF_CostCentreStack = 96,+      pc_OFFSET_CostCentreStack_mem_alloc = 72,+      pc_REP_CostCentreStack_mem_alloc = 8,+      pc_OFFSET_CostCentreStack_scc_count = 48,+      pc_REP_CostCentreStack_scc_count = 8,+      pc_OFFSET_StgHeader_ccs = 8,+      pc_OFFSET_StgHeader_ldvw = 16,+      pc_SIZEOF_StgSMPThunkHeader = 8,+      pc_OFFSET_StgEntCounter_allocs = 48,+      pc_REP_StgEntCounter_allocs = 8,+      pc_OFFSET_StgEntCounter_allocd = 16,+      pc_REP_StgEntCounter_allocd = 8,+      pc_OFFSET_StgEntCounter_registeredp = 0,+      pc_OFFSET_StgEntCounter_link = 56,+      pc_OFFSET_StgEntCounter_entry_count = 40,+      pc_SIZEOF_StgUpdateFrame_NoHdr = 8,+      pc_SIZEOF_StgMutArrPtrs_NoHdr = 16,+      pc_OFFSET_StgMutArrPtrs_ptrs = 0,+      pc_OFFSET_StgMutArrPtrs_size = 8,+      pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 8,+      pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0,+      pc_SIZEOF_StgArrBytes_NoHdr = 8,+      pc_OFFSET_StgArrBytes_bytes = 0,+      pc_OFFSET_StgTSO_alloc_limit = 96,+      pc_OFFSET_StgTSO_cccs = 112,+      pc_OFFSET_StgTSO_stackobj = 16,+      pc_OFFSET_StgStack_sp = 8,+      pc_OFFSET_StgStack_stack = 16,+      pc_OFFSET_StgUpdateFrame_updatee = 0,+      pc_OFFSET_StgFunInfoExtraFwd_arity = 4,+      pc_REP_StgFunInfoExtraFwd_arity = 4,+      pc_SIZEOF_StgFunInfoExtraRev = 24,+      pc_OFFSET_StgFunInfoExtraRev_arity = 20,+      pc_REP_StgFunInfoExtraRev_arity = 4,+      pc_MAX_SPEC_SELECTEE_SIZE = 15,+      pc_MAX_SPEC_AP_SIZE = 7,+      pc_MIN_PAYLOAD_SIZE = 1,+      pc_MIN_INTLIKE = -16,+      pc_MAX_INTLIKE = 255,+      pc_MIN_CHARLIKE = 0,+      pc_MAX_CHARLIKE = 255,+      pc_MUT_ARR_PTRS_CARD_BITS = 7,+      pc_MAX_Vanilla_REG = 10,+      pc_MAX_Float_REG = 6,+      pc_MAX_Double_REG = 6,+      pc_MAX_Long_REG = 1,+      pc_MAX_XMM_REG = 6,+      pc_MAX_Real_Vanilla_REG = 6,+      pc_MAX_Real_Float_REG = 6,+      pc_MAX_Real_Double_REG = 6,+      pc_MAX_Real_XMM_REG = 6,+      pc_MAX_Real_Long_REG = 0,+      pc_RESERVED_C_STACK_BYTES = 16384,+      pc_RESERVED_STACK_WORDS = 21,+      pc_AP_STACK_SPLIM = 1024,+      pc_WORD_SIZE = 8,+      pc_DOUBLE_SIZE = 8,+      pc_CINT_SIZE = 4,+      pc_CLONG_SIZE = 8,+      pc_CLONG_LONG_SIZE = 8,+      pc_BITMAP_BITS_SHIFT = 6,+      pc_TAG_BITS = 3,+      pc_WORDS_BIGENDIAN = False,+      pc_DYNAMIC_BY_DEFAULT = False,+      pc_LDV_SHIFT = 30,+      pc_ILDV_CREATE_MASK = 1152921503533105152,+      pc_ILDV_STATE_CREATE = 0,+      pc_ILDV_STATE_USE = 1152921504606846976   }
ghc-lib/stage0/lib/settings view
@@ -1,36 +1,49 @@-[("GCC extra via C opts", " -fwrapv -fno-builtin"),- ("C compiler command", "gcc"),- ("C compiler flags", ""),- ("C compiler link flags", " "),- ("C compiler supports -no-pie", "NO"),- ("Haskell CPP command","gcc"),- ("Haskell CPP flags","-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs"),- ("ld command", "ld"),- ("ld flags", ""),- ("ld supports compact unwind", "YES"),- ("ld supports build-id", "NO"),- ("ld supports filelist", "YES"),- ("ld is GNU ld", "NO"),- ("ar command", "ar"),- ("ar flags", "qcls"),- ("ar supports at file", "NO"),- ("ranlib command", "ranlib"),- ("touch command", "touch"),- ("dllwrap command", "/bin/false"),- ("windres command", "/bin/false"),- ("libtool command", "libtool"),- ("perl command", "/usr/bin/perl"),- ("cross compiling", "NO"),- ("target os", "OSDarwin"),- ("target arch", "ArchX86_64"),- ("target word size", "8"),- ("target has GNU nonexec stack", "False"),- ("target has .ident directive", "True"),- ("target has subsections via symbols", "True"),- ("target has RTS linker", "YES"),- ("Unregisterised", "NO"),- ("LLVM llc command", "llc"),- ("LLVM opt command", "opt"),- ("LLVM clang command", "clang")- ]-+[("GCC extra via C opts", "")+,("C compiler command", "cc")+,("C compiler flags", "")+,("C++ compiler flags", "")+,("C compiler link flags", "")+,("C compiler supports -no-pie", "NO")+,("Haskell CPP command", "cc")+,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs")+,("ld command", "ld")+,("ld flags", "")+,("ld supports compact unwind", "YES")+,("ld supports build-id", "NO")+,("ld supports filelist", "YES")+,("ld is GNU ld", "NO")+,("ar command", "ar")+,("ar flags", "qcls")+,("ar supports at file", "NO")+,("ranlib command", "ranlib")+,("touch command", "touch")+,("dllwrap command", "/bin/false")+,("windres command", "/bin/false")+,("libtool command", "libtool")+,("unlit command", "$topdir/bin/unlit")+,("cross compiling", "NO")+,("target platform string", "x86_64-apple-darwin")+,("target os", "OSDarwin")+,("target arch", "ArchX86_64")+,("target word size", "8")+,("target has GNU nonexec stack", "NO")+,("target has .ident directive", "YES")+,("target has subsections via symbols", "YES")+,("target has RTS linker", "YES")+,("Unregisterised", "NO")+,("LLVM target", "x86_64-apple-darwin")+,("LLVM llc command", "llc")+,("LLVM opt command", "opt")+,("LLVM clang command", "clang")+,("integer library", "integer-simple")+,("Use interpreter", "YES")+,("Use native code generator", "YES")+,("Support SMP", "YES")+,("RTS ways", "v thr")+,("Tables next to code", "YES")+,("Leading underscore", "YES")+,("Use LibFFI", "NO")+,("Use Threads", "YES")+,("Use Debugging", "NO")+,("RTS expects libdw", "NO")+]
+ ghc-lib/stage0/libraries/ghc-boot/build/GHC/Platform/Host.hs view
@@ -0,0 +1,15 @@+module GHC.Platform.Host where++import GHC.Platform++cHostPlatformArch :: Arch+cHostPlatformArch = ArchX86_64++cHostPlatformOS   :: OS+cHostPlatformOS   = OSDarwin++cHostPlatformMini :: PlatformMini+cHostPlatformMini = PlatformMini+  { platformMini_arch = cHostPlatformArch+  , platformMini_os = cHostPlatformOS+  }
includes/CodeGen.Platform.hs view
@@ -6,7 +6,6 @@ #endif import Reg -#include "ghcautoconf.h" #include "stg/MachRegs.h"  #if defined(MACHREGS_i386) || defined(MACHREGS_x86_64)@@ -41,65 +40,59 @@ #  define r15   15 # endif -# define fake0 16-# define fake1 17-# define fake2 18-# define fake3 19-# define fake4 20-# define fake5 21  -- N.B. XMM, YMM, and ZMM are all aliased to the same hardware registers hence -- being assigned the same RegNos.-# define xmm0  24-# define xmm1  25-# define xmm2  26-# define xmm3  27-# define xmm4  28-# define xmm5  29-# define xmm6  30-# define xmm7  31-# define xmm8  32-# define xmm9  33-# define xmm10 34-# define xmm11 35-# define xmm12 36-# define xmm13 37-# define xmm14 38-# define xmm15 39+# define xmm0  16+# define xmm1  17+# define xmm2  18+# define xmm3  19+# define xmm4  20+# define xmm5  21+# define xmm6  22+# define xmm7  23+# define xmm8  24+# define xmm9  25+# define xmm10 26+# define xmm11 27+# define xmm12 28+# define xmm13 29+# define xmm14 30+# define xmm15 31 -# define ymm0  24-# define ymm1  25-# define ymm2  26-# define ymm3  27-# define ymm4  28-# define ymm5  29-# define ymm6  30-# define ymm7  31-# define ymm8  32-# define ymm9  33-# define ymm10 34-# define ymm11 35-# define ymm12 36-# define ymm13 37-# define ymm14 38-# define ymm15 39+# define ymm0  16+# define ymm1  17+# define ymm2  18+# define ymm3  19+# define ymm4  20+# define ymm5  21+# define ymm6  22+# define ymm7  23+# define ymm8  24+# define ymm9  25+# define ymm10 26+# define ymm11 27+# define ymm12 28+# define ymm13 29+# define ymm14 30+# define ymm15 31 -# define zmm0  24-# define zmm1  25-# define zmm2  26-# define zmm3  27-# define zmm4  28-# define zmm5  29-# define zmm6  30-# define zmm7  31-# define zmm8  32-# define zmm9  33-# define zmm10 34-# define zmm11 35-# define zmm12 36-# define zmm13 37-# define zmm14 38-# define zmm15 39+# define zmm0  16+# define zmm1  17+# define zmm2  18+# define zmm3  19+# define zmm4  20+# define zmm5  21+# define zmm6  22+# define zmm7  23+# define zmm8  24+# define zmm9  25+# define zmm10 26+# define zmm11 27+# define zmm12 28+# define zmm13 29+# define zmm14 30+# define zmm15 31  -- Note: these are only needed for ARM/ARM64 because globalRegMaybe is now used in CmmSink.hs. -- Since it's only used to check 'isJust', the actual values don't matter, thus@@ -351,6 +344,42 @@ # define f30 62 # define f31 63 +#elif defined(MACHREGS_s390x)++# define r0   0+# define r1   1+# define r2   2+# define r3   3+# define r4   4+# define r5   5+# define r6   6+# define r7   7+# define r8   8+# define r9   9+# define r10 10+# define r11 11+# define r12 12+# define r13 13+# define r14 14+# define r15 15++# define f0  16+# define f1  17+# define f2  18+# define f3  19+# define f4  20+# define f5  21+# define f6  22+# define f7  23+# define f8  24+# define f9  25+# define f10 26+# define f11 27+# define f12 28+# define f13 29+# define f14 30+# define f15 31+ #endif  callerSaves :: GlobalReg -> Bool@@ -637,7 +666,8 @@ globalRegMaybe :: GlobalReg -> Maybe RealReg #if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \     || defined(MACHREGS_sparc) || defined(MACHREGS_powerpc) \-    || defined(MACHREGS_arm) || defined(MACHREGS_aarch64)+    || defined(MACHREGS_arm) || defined(MACHREGS_aarch64) \+    || defined(MACHREGS_s390x) # if defined(REG_Base) globalRegMaybe BaseReg                  = Just (RealRegSingle REG_Base) # endif@@ -904,78 +934,9 @@ # if defined(REG_Base) freeReg REG_Base  = False # endif-# if defined(REG_R1)-freeReg REG_R1    = False-# endif-# if defined(REG_R2)-freeReg REG_R2    = False-# endif-# if defined(REG_R3)-freeReg REG_R3    = False-# endif-# if defined(REG_R4)-freeReg REG_R4    = False-# endif-# if defined(REG_R5)-freeReg REG_R5    = False-# endif-# if defined(REG_R6)-freeReg REG_R6    = False-# endif-# if defined(REG_R7)-freeReg REG_R7    = False-# endif-# if defined(REG_R8)-freeReg REG_R8    = False-# endif-# if defined(REG_R9)-freeReg REG_R9    = False-# endif-# if defined(REG_R10)-freeReg REG_R10   = False-# endif-# if defined(REG_F1)-freeReg REG_F1    = False-# endif-# if defined(REG_F2)-freeReg REG_F2    = False-# endif-# if defined(REG_F3)-freeReg REG_F3    = False-# endif-# if defined(REG_F4)-freeReg REG_F4    = False-# endif-# if defined(REG_F5)-freeReg REG_F5    = False-# endif-# if defined(REG_F6)-freeReg REG_F6    = False-# endif-# if defined(REG_D1)-freeReg REG_D1    = False-# endif-# if defined(REG_D2)-freeReg REG_D2    = False-# endif-# if defined(REG_D3)-freeReg REG_D3    = False-# endif-# if defined(REG_D4)-freeReg REG_D4    = False-# endif-# if defined(REG_D5)-freeReg REG_D5    = False-# endif-# if defined(REG_D6)-freeReg REG_D6    = False-# endif # if defined(REG_Sp) freeReg REG_Sp    = False # endif-# if defined(REG_Su)-freeReg REG_Su    = False-# endif # if defined(REG_SpLim) freeReg REG_SpLim = False # endif@@ -1118,9 +1079,6 @@ # endif # if defined(REG_Sp) freeReg REG_Sp    = False-# endif-# if defined(REG_Su)-freeReg REG_Su    = False # endif # if defined(REG_SpLim) freeReg REG_SpLim = False
includes/MachDeps.h view
@@ -9,7 +9,7 @@  * NB: THIS FILE IS INCLUDED IN HASKELL SOURCE!  *  * To understand the structure of the RTS headers, see the wiki:- *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes  *  * ---------------------------------------------------------------------------*/ @@ -18,14 +18,14 @@ /* Don't allow stage1 (cross-)compiler embed assumptions about target  * platform. When ghc-stage1 is being built by ghc-stage0 is should not  * refer to target defines. A few past examples:- *  - https://ghc.haskell.org/trac/ghc/ticket/13491+ *  - https://gitlab.haskell.org/ghc/ghc/issues/13491  *  - https://phabricator.haskell.org/D3122  *  - https://phabricator.haskell.org/D3405  *  * In those cases code change assumed target defines like SIZEOF_HSINT  * are applied to host platform, not target platform.  *- * So what should be used instead in STAGE=1?+ * So what should be used instead in GHC_STAGE=1?  *  * To get host's equivalent of SIZEOF_HSINT you can use Bits instances:  *    Data.Bits.finiteBitSize (0 :: Int)@@ -34,9 +34,9 @@  * configuration from 'targetPlatform :: DynFlags -> Platform'  * record. A few wrappers are already defined and used throughout GHC:  *    wORD_SIZE :: DynFlags -> Int- *    wORD_SIZE dflags = pc_WORD_SIZE (sPlatformConstants (settings dflags))+ *    wORD_SIZE dflags = pc_WORD_SIZE (platformConstants dflags)  *- * Hence we hide these macros from -DSTAGE=1+ * Hence we hide these macros from GHC_STAGE=1  */  /* Sizes of C types come from here... */
includes/stg/MachRegs.h view
@@ -8,7 +8,7 @@  * Do not #include this file directly: #include "Rts.h" instead.  *  * To understand the structure of the RTS headers, see the wiki:- *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes  *  * ---------------------------------------------------------------------------*/ @@ -312,6 +312,8 @@ #define REG_R6          r19 #define REG_R7          r20 #define REG_R8          r21+#define REG_R9          r22+#define REG_R10         r23  #define REG_F1          fr14 #define REG_F2          fr15@@ -327,13 +329,14 @@ #define REG_D5          fr24 #define REG_D6          fr25 -#define REG_Sp          r22-#define REG_SpLim       r24--#define REG_Hp          r25-+#define REG_Sp          r24+#define REG_SpLim       r25+#define REG_Hp          r26 #define REG_Base        r27 +#define MAX_REAL_FLOAT_REG   6+#define MAX_REAL_DOUBLE_REG  6+ /* -----------------------------------------------------------------------------    The Sun SPARC register mapping @@ -585,6 +588,78 @@ #define REG_D2          d13 #define REG_D3          d14 #define REG_D4          d15++/* -----------------------------------------------------------------------------+   The s390x register mapping++   Register    | Role(s)                                 | Call effect+   ------------+-------------------------------------+-----------------+   r0,r1       | -                                       | caller-saved+   r2          | Argument / return value                 | caller-saved+   r3,r4,r5    | Arguments                               | caller-saved+   r6          | Argument                                | callee-saved+   r7...r11    | -                                       | callee-saved+   r12         | (Commonly used as GOT pointer)          | callee-saved+   r13         | (Commonly used as literal pool pointer) | callee-saved+   r14         | Return address                          | caller-saved+   r15         | Stack pointer                           | callee-saved+   f0          | Argument / return value                 | caller-saved+   f2,f4,f6    | Arguments                               | caller-saved+   f1,f3,f5,f7 | -                                       | caller-saved+   f8...f15    | -                                       | callee-saved+   v0...v31    | -                                       | caller-saved++   Each general purpose register r0 through r15 as well as each floating-point+   register f0 through f15 is 64 bits wide. Each vector register v0 through v31+   is 128 bits wide.++   Note, the vector registers v0 through v15 overlap with the floating-point+   registers f0 through f15.++   -------------------------------------------------------------------------- */++#elif defined(MACHREGS_s390x)++#define REG(x) __asm__("%" #x)++#define REG_Base        r7+#define REG_Sp          r8+#define REG_Hp          r10+#define REG_R1          r11+#define REG_R2          r12+#define REG_R3          r13+#define REG_R4          r6+#define REG_R5          r2+#define REG_R6          r3+#define REG_R7          r4+#define REG_R8          r5+#define REG_SpLim       r9+#define REG_MachSp      r15++#define REG_F1          f8+#define REG_F2          f9+#define REG_F3          f10+#define REG_F4          f11+#define REG_F5          f0+#define REG_F6          f1++#define REG_D1          f12+#define REG_D2          f13+#define REG_D3          f14+#define REG_D4          f15+#define REG_D5          f2+#define REG_D6          f3++#define CALLER_SAVES_R5+#define CALLER_SAVES_R6+#define CALLER_SAVES_R7+#define CALLER_SAVES_R8++#define CALLER_SAVES_F5+#define CALLER_SAVES_F6++#define CALLER_SAVES_D5+#define CALLER_SAVES_D6  #else
+ libraries/ghc-boot/GHC/Settings.hs view
@@ -0,0 +1,106 @@+-- Note [Settings file]+-- ~~~~~~~~~~~~~~~~~~~~+--+-- GHC has a file, `${top_dir}/settings`, which is the main source of run-time+-- configuration. ghc-pkg needs just a little bit of it: the target platform CPU+-- arch and OS. It uses that to figure out what subdirectory of `~/.ghc` is+-- associated with the current version/target.+--+-- This module has just enough code to read key value pairs from the settings+-- file, and read the target platform from those pairs.+--+-- The  "0" suffix is because the caller will partially apply it, and that will+-- in turn be used a few more times.+module GHC.Settings where++import Prelude -- See Note [Why do we import Prelude here?]++import GHC.BaseDir+import GHC.Platform++import Data.Char (isSpace)+import Data.Map (Map)+import qualified Data.Map as Map++-----------------------------------------------------------------------------+-- parts of settings file++getTargetPlatform+  :: FilePath -> RawSettings -> Either String Platform+getTargetPlatform settingsFile mySettings = do+  let+    getBooleanSetting = getBooleanSetting0 settingsFile mySettings+    readSetting :: (Show a, Read a) => String -> Either String a+    readSetting = readSetting0 settingsFile mySettings++  targetArch <- readSetting "target arch"+  targetOS <- readSetting "target os"+  targetWordSize <- readSetting "target word size"+  targetUnregisterised <- getBooleanSetting "Unregisterised"+  targetHasGnuNonexecStack <- getBooleanSetting "target has GNU nonexec stack"+  targetHasIdentDirective <- getBooleanSetting "target has .ident directive"+  targetHasSubsectionsViaSymbols <- getBooleanSetting "target has subsections via symbols"+  crossCompiling <- getBooleanSetting "cross compiling"++  pure $ Platform+    { platformMini = PlatformMini+      { platformMini_arch = targetArch+      , platformMini_os = targetOS+      }+    , platformWordSize = targetWordSize+    , platformUnregisterised = targetUnregisterised+    , platformHasGnuNonexecStack = targetHasGnuNonexecStack+    , platformHasIdentDirective = targetHasIdentDirective+    , platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols+    , platformIsCrossCompiling = crossCompiling+    }++-----------------------------------------------------------------------------+-- settings file helpers++type RawSettings = Map String String++-- | See Note [Settings file] for "0" suffix+getSetting0+  :: FilePath -> RawSettings -> String -> Either String String+getSetting0 settingsFile mySettings key = case Map.lookup key mySettings of+  Just xs -> Right xs+  Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile++-- | See Note [Settings file] for "0" suffix+getFilePathSetting0+  :: FilePath -> FilePath -> RawSettings -> String -> Either String String+getFilePathSetting0 top_dir settingsFile mySettings key =+  expandTopDir top_dir <$> getSetting0 settingsFile mySettings key++-- | See Note [Settings file] for "0" suffix+getBooleanSetting0+  :: FilePath -> RawSettings -> String -> Either String Bool+getBooleanSetting0 settingsFile mySettings key = do+  rawValue <- getSetting0 settingsFile mySettings key+  case rawValue of+    "YES" -> Right True+    "NO" -> Right False+    xs -> Left $ "Bad value for " ++ show key ++ ": " ++ show xs++-- | See Note [Settings file] for "0" suffix+readSetting0+  :: (Show a, Read a) => FilePath -> RawSettings -> String -> Either String a+readSetting0 settingsFile mySettings key = case Map.lookup key mySettings of+  Just xs -> case maybeRead xs of+    Just v -> Right v+    Nothing -> Left $ "Failed to read " ++ show key ++ " value " ++ show xs+  Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile++-----------------------------------------------------------------------------+-- read helpers++maybeRead :: Read a => String -> Maybe a+maybeRead str = case reads str of+  [(x, "")] -> Just x+  _ -> Nothing++maybeReadFuzzy :: Read a => String -> Maybe a+maybeReadFuzzy str = case reads str of+  [(x, s)] | all isSpace s -> Just x+  _ -> Nothing
libraries/ghci/GHCi/InfoTable.hsc view
@@ -10,28 +10,25 @@ -- module GHCi.InfoTable   (-#ifdef GHCI     mkConInfoTable-#endif   ) where  import Prelude -- See note [Why do we import Prelude here?]-#ifdef GHCI import Foreign import Foreign.C import GHC.Ptr import GHC.Exts import GHC.Exts.Heap-#endif+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS  ghciTablesNextToCode :: Bool-#ifdef TABLES_NEXT_TO_CODE+#if defined(TABLES_NEXT_TO_CODE) ghciTablesNextToCode = True #else ghciTablesNextToCode = False #endif -#ifdef GHCI /* To end */ -- NOTE: Must return a pointer acceptable for use in the header of a closure. -- If tables_next_to_code is enabled, then it must point the the 'code' field. -- Otherwise, it should point to the start of the StgInfoTable.@@ -40,7 +37,7 @@    -> Int     -- non-ptr words    -> Int     -- constr tag    -> Int     -- pointer tag-   -> [Word8]  -- con desc+   -> ByteString  -- con desc    -> IO (Ptr StgInfoTable)       -- resulting info table is allocated with allocateExec(), and       -- should be freed with freeExec().@@ -79,6 +76,7 @@           | ArchARM64           | ArchPPC64           | ArchPPC64LE+          | ArchS390X           | ArchUnknown  deriving Show @@ -102,6 +100,8 @@        ArchPPC64 #elif defined(powerpc64le_HOST_ARCH)        ArchPPC64LE+#elif defined(s390x_HOST_ARCH)+       ArchS390X #else #    if defined(TABLES_NEXT_TO_CODE) #        error Unimplemented architecture@@ -271,6 +271,20 @@                    0x618C0000 .|. lo16 w32,                    0x7D8903A6, 0x4E800420 ] +    ArchS390X ->+        -- Let 0xAABBCCDDEEFFGGHH be the address to jump to.+        -- The following code loads the address into scratch+        -- register r1 and jumps to it.+        --+        --    0:   C0 1E AA BB CC DD       llihf   %r1,0xAABBCCDD+        --    6:   C0 19 EE FF GG HH       iilf    %r1,0xEEFFGGHH+        --   12:   07 F1                   br      %r1++        let w64 = fromIntegral (funPtrToInt a) :: Word64+        in Left [ 0xC0, 0x1E, byte7 w64, byte6 w64, byte5 w64, byte4 w64,+                  0xC0, 0x19, byte3 w64, byte2 w64, byte1 w64, byte0 w64,+                  0x07, 0xF1 ]+     -- This code must not be called. You either need to     -- add your architecture as a distinct case or     -- use non-TABLES_NEXT_TO_CODE mode@@ -344,10 +358,10 @@        Right xs -> sizeOf (head xs) * length xs  -- Note: Must return proper pointer for use in a closure-newExecConItbl :: StgInfoTable -> [Word8] -> IO (FunPtr ())+newExecConItbl :: StgInfoTable -> ByteString -> IO (FunPtr ()) newExecConItbl obj con_desc    = alloca $ \pcode -> do-        let lcon_desc = length con_desc + 1{- null terminator -}+        let lcon_desc = BS.length con_desc + 1{- null terminator -}             -- SCARY             -- This size represents the number of bytes in an StgConInfoTable.             sz = fromIntegral (conInfoTableSizeB + sizeOfEntryCode)@@ -360,7 +374,10 @@         let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz                                     , infoTable = obj }         pokeConItbl wr_ptr ex_ptr cinfo-        pokeArray0 0 (castPtr wr_ptr `plusPtr` fromIntegral sz) con_desc+        BS.useAsCStringLen con_desc $ \(src, len) ->+            copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len+        let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)+        poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)         _flushExec sz ex_ptr -- Cache flush (if needed) #if defined(TABLES_NEXT_TO_CODE)         return (castPtrToFunPtr (ex_ptr `plusPtr` conInfoTableSizeB))@@ -382,4 +399,3 @@  conInfoTableSizeB :: Int conInfoTableSizeB = wORD_SIZE + itblSize-#endif /* GHCI */
libraries/ghci/GHCi/Run.hs view
@@ -44,9 +44,13 @@ -- ----------------------------------------------------------------------------- -- Implement messages +foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()+        -- Make it "safe", just in case+ run :: Message a -> IO a run m = case m of   InitLinker -> initObjLinker RetainCAFs+  RtsRevertCAFs -> rts_revertCAFs   LookupSymbol str -> fmap toRemotePtr <$> lookupSymbol str   LookupClosure str -> lookupClosure str   LoadDLL str -> loadDLL str
libraries/ghci/GHCi/TH.hs view
@@ -183,6 +183,7 @@   qLookupName isType occ = ghcCmd (LookupName isType occ)   qReify name = ghcCmd (Reify name)   qReifyFixity name = ghcCmd (ReifyFixity name)+  qReifyType name = ghcCmd (ReifyType name)   qReifyInstances name tys = ghcCmd (ReifyInstances name tys)   qReifyRoles name = ghcCmd (ReifyRoles name) @@ -265,7 +266,7 @@ runTHQ   :: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a   -> IO ByteString-runTHQ pipe@Pipe{..} rstate mb_loc ghciq = do+runTHQ pipe rstate mb_loc ghciq = do   qstateref <- localRef rstate   qstate <- readIORef qstateref   let st = qstate { qsLocation = mb_loc, qsPipe = pipe }
libraries/template-haskell/Language/Haskell/TH/Quote.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes, ScopedTypeVariables, Safe #-} {- | Module : Language.Haskell.TH.Quote Description : Quasi-quoting support for Template Haskell