packages feed

ghc-lib 0.20191002 → 0.20191101

raw patch · 160 files changed

+14587/−11329 lines, 160 filesdep ~ghc-lib-parser

Dependency ranges changed: ghc-lib-parser

Files

+ compiler/GHC/HsToCore/PmCheck.hs view
@@ -0,0 +1,1384 @@+{-+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 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    :: UncoveredCandidates+    , 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)+    ]++-- | 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 [Id] [Delta]+                         | TypeOfUncovered Type++instance Outputable UncoveredCandidates where+  ppr (UncoveredPatterns vva deltas) = text "UnPat" <+> ppr vva $$ ppr deltas+  ppr (TypeOfUncovered ty)   = text "UnTy" <+> ppr 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+  tracePm "checkSingle" (vcat [ppr ctxt, ppr var, ppr p])+  res <- checkSingle' locn var p+  dsPmWarn dflags ctxt 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 uc = UncoveredPatterns [var] us'+  return $ case (cs,ds) of+    (Covered,  _    )         -> PmResult [] uc [] pc -- useful+    (NotCovered, NotDiverged) -> PmResult m  uc [] pc -- redundant+    (NotCovered, Diverged )   -> PmResult [] uc m  pc -- 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 <- case matches of+    -- Check EmptyCase separately+    -- See Note [Checking EmptyCase Expressions] in GHC.HsToCore.PmCheck.Oracle+    [] | [var] <- vars -> checkEmptyCase' var+    _normal_match      -> checkMatches' vars matches+  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)] -> DsM PmResult+checkMatches' vars matches+  | null matches = panic "checkMatches': EmptyCase"+  | otherwise = do+      missing    <- getPmDelta+      tracePm "checkMatches': missing" (ppr missing)+      (rs,us,ds,pc) <- go matches [missing]+      dflags <- getDynFlags+      us' <- getNFirstUncovered vars (maxUncoveredPatterns dflags + 1) us+      let up = UncoveredPatterns vars us'+      return $ PmResult {+                   pmresultRedundant    = map hsLMatchToLPats rs+                 , pmresultUncovered    = up+                 , 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'"++-- | Check an empty case expression. Since there are no clauses to process, we+--   only compute the uncovered set. See Note [Checking EmptyCase Expressions]+--   in "GHC.HsToCore.PmCheck.Oracle" for details.+checkEmptyCase' :: Id -> DsM PmResult+checkEmptyCase' x = do+  delta         <- getPmDelta+  us <- inhabitants delta (idType x) >>= \case+    -- Inhabitation checking failed / the type is trivially inhabited+    Left ty            -> pure (TypeOfUncovered ty)+    -- A list of oracle states for the different satisfiable constructors is+    -- available. Turn this into a value set abstraction.+    Right (va, deltas) -> pure (UncoveredPatterns [va] deltas)+  pure (PmResult [] us [] Precise)++getNFirstUncovered :: [Id] -> Int -> [Delta] -> DsM [Delta]+getNFirstUncovered _    0 _              = pure []+getNFirstUncovered _    _ []             = pure []+getNFirstUncovered vars n (delta:deltas) = do+  front <- provideEvidenceForEquation vars n delta+  back <- getNFirstUncovered vars (n - length front) deltas+  pure (front ++ back)++{-+%************************************************************************+%*                                                                      *+              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)+  -- XPat wraps a Located (Pat GhcTc) in GhcTc. The Located part is important+  XPat     p   -> translatePat fam_insts x (unLoc p)+  ParPat _ p   -> translatePat 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 :) <$> translatePat 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 ++) <$> translatePat fam_insts y p++  SigPat _ p _ty -> translatePat 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) <- translatePatV 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 <- selectMatchVar pat+        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 (translatePatV 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) <- translatePatV 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"++-- | '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)++-- | @translateListPat _ x [p1, ..., pn]@ is basically+--   @translateConPatOut _ x $(mkListConPatOuts [p1, ..., pn]>@ without ever+-- constructing the 'ConPatOut's.+translateListPat :: FamInstEnvs -> Id -> [Pat GhcTc] -> DsM GrdVec+translateListPat fam_insts x pats = do+  vars_and_grdss <- traverse (translatePatV 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) <- translatePatV 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 (translatePat 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 -> Pat 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+    -> translatePat fam_insts y p+  rhs -> do+    x <- selectMatchVar p+    (PmLet x rhs :) <$> translatePat fam_insts x p++-- | 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+  let pr_pos' = forceIfCanDiverge delta x 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++-- ----------------------------------------------------------------------------+-- * 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 -> PmResult -> DsM ()+dsPmWarn dflags ctx@(DsMatchContext kind loc) 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 && (case uncovered of+                                  TypeOfUncovered   _     -> True+                                  UncoveredPatterns _ unc -> notNull unc)+          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 $+        case uncovered of+          TypeOfUncovered ty    -> warnEmptyCase ty+          UncoveredPatterns vars unc -> pprEqns vars unc+  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)++    -- 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 = pprContext False ctx (text "are non-exhaustive") $ \_ ->+      hang (text "Patterns not matched:") 4 (underscore <+> dcolon <+> ppr ty)++    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,1644 @@+{-+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 'provideEvidenceForEquation' to turn a+-- 'Delta' into a concrete evidence for an equation.+module GHC.HsToCore.PmCheck.Oracle (++        DsM, tracePm, mkPmId,+        Delta, initDelta, canDiverge, lookupRefuts, lookupSolution,++        TmCt(..),+        inhabitants,+        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+        provideEvidenceForEquation,+    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.HsToCore.PmCheck.Types++import DynFlags+import Outputable+import ErrUtils+import Util+import Bag+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)+import Data.List     (find)+import qualified Data.List.NonEmpty as NonEmpty+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 con (PM tc ms) = PM tc (fmap (`delOneFromUniqDSet` con) ms)+markMatched _   NoPM = NoPM++-- | Satisfiability decisions as a data type. The @proof@ can carry a witness+-- for satisfiability and might even be instantiated to 'Data.Void.Void' to+-- degenerate into a semi-decision predicate.+data Satisfiability proof+  = Unsatisfiable+  | PossiblySatisfiable+  | Satisfiable !proof++maybeSatisfiable :: Maybe a -> Satisfiability a+maybeSatisfiable (Just a) = Satisfiable a+maybeSatisfiable Nothing  = Unsatisfiable++-- | Tries to return one of the possible 'ConLike's from one of the COMPLETE+-- sets. If the 'PossibleMatches' was inhabited before (cf. 'ensureInhabited')+-- this 'ConLike' is evidence for that assurance.+getUnmatchedConstructor :: PossibleMatches -> Satisfiability ConLike+getUnmatchedConstructor NoPM = PossiblySatisfiable+getUnmatchedConstructor (PM _tc ms)+  = maybeSatisfiable $ NonEmpty.head <$> traverse pick_one_conlike ms+  where+    pick_one_conlike cs = case uniqDSetToList cs of+      [] -> Nothing+      (cl:_) -> Just cl++---------------------------------------------------+-- * 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_banged = map isBanged $ conLikeImplBangs con+      strict_arg_tys = filterByList arg_is_banged 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+  -- ^ '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, so that we don't have to+  -- reconstruct it in inhabitationCandidates.build_newtype.++-- | 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++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 EmptyCase] 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 for EmptyCase].+       (_, 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, DataCon)])+    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):)+                           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 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 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 and the type we unwrap.+  (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,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, 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+       ; ((_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 -> do+  tracePm "tyIsSatisfiable" (ppr new_ty_cs)+  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_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 tc_rep (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 a constraint (x ~ BOT) can succeed,+-- given the resulting state of the term oracle.+canDiverge :: Delta -> Id -> Bool+canDiverge MkDelta{ delta_tm_st = ts } x+  -- If the variable seems not evaluated, there is a possibility for+  -- constraint x ~ BOT to be satisfiable. That's the case when we haven't found+  -- a solution (i.e. some equivalent literal or constructor) for it yet.+  -- Even if we don't have a solution yet, it might be involved in a negative+  -- constraint, in which case we must already have evaluated it earlier.+  | VI _ [] [] _ <- lookupVarInfo ts x+  = True+  -- Variable x is already in WHNF or we know some refutable shape, so the+  -- constraint is non-satisfiable+  | otherwise = False++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) guarantees that 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 tc ms) = runMaybeT (PM tc <$> 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+          -- 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+    -- All these types are trivially inhabited+    trivially_inhabited = [ charTyCon, doubleTyCon, floatTyCon+                          , intTyCon, wordTyCon, word8TyCon ]++    build_newtype :: (Type, DataCon) -> Id -> DsM (Id, TmCt)+    build_newtype (ty, dc) 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)] -> 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)]+                  -> DsM (Either Type (TyCon, Id, [InhabitationCandidate]))+    alts_to_check src_ty core_ty dcs = case splitTyConApp_maybe core_ty of+      Just (tc, _)+        |  tc `elem` trivially_inhabited+        -> 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)++inhabitants :: Delta -> Type -> DsM (Either Type (Id, [Delta]))+inhabitants delta ty = inhabitationCandidates delta ty >>= \case+  Left ty' -> pure (Left ty')+  Right (_, va, candidates) -> do+    deltas <- flip mapMaybeM candidates $+        \InhabitationCandidate{ ic_tm_cs = tm_cs+                              , ic_ty_cs = ty_cs+                              , ic_strict_arg_tys = strict_arg_tys } -> do+      pmIsSatisfiable delta tm_cs ty_cs strict_arg_tys+    pure (Right (va, deltas))++----------------------------+-- * 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 for EmptyCase]+   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) -> 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++-- | @provideEvidenceForEquation 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.+provideEvidenceForEquation :: [Id] -> Int -> Delta -> DsM [Delta]+provideEvidenceForEquation = go init_ts+  where+    -- Choosing 1 here will not be enough for RedBlack, but any other bound+    -- might potentially lead to combinatorial explosion, so we are extremely+    -- cautious and pick 2 here.+    init_ts                  = setRecTcMaxBound 2 initRecTc+    go _      _      0 _     = pure []+    go _      []     _ delta = pure [delta]+    go rec_ts (x:xs) n delta = do+      VI ty pos neg pm <- 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 rec_ts (arg_vas ++ xs) n delta+        []+          -- First the simple case where we don't need to query the oracles+          | isVanillaDataType ty+              -- So no type info unleashed in pattern match+          , null neg+              -- No term-level info either+          || notNull [ l | PmAltLit l <- neg ]+              -- ... or there are literals involved, in which case we don't want+              -- to split on possible constructors+          -> go rec_ts xs n delta+        [] -> do+          -- We have to pick one of the available constructors and try it+          -- It's important that each of the ConLikeSets in pm is still inhabited,+          -- so that it doesn't matter from which we pick.+          -- I think we implicitly uphold that invariant, but not too sure+          case getUnmatchedConstructor pm of+            Unsatisfiable -> pure []+            -- No COMPLETE sets available, so we can assume it's inhabited+            PossiblySatisfiable -> go rec_ts xs n delta+            Satisfiable cl+              | Just rec_ts' <- checkRecTc rec_ts (fst (splitTyConApp ty))+              -> split_at_con rec_ts' delta n x xs cl+              | otherwise+              -- We ran out of fuel; just conservatively assume that this is+              -- inhabited.+              -> go rec_ts xs n delta++    -- | @split_at_con _ delta _ x _ con@ splits the given delta into two+    -- models: One where we assume x is con and one where we assume it can't be+    -- con. Really similar to the ConVar case in Check, only that we don't+    -- really have a pattern driving the split.+    split_at_con+      :: RecTcChecker -- ^ Detects when we split the same TyCon too often+      -> Delta        -- ^ The model we like to refine to the split+      -> Int          -- ^ The number of equations still to produce+      -> Id -> [Id]   -- ^ Head and tail of the value abstractions+      -> ConLike      -- ^ The ConLike over which to split+      -> DsM [Delta]+    split_at_con rec_ts delta n x xs cl = do+      -- This will be really similar to the ConVar case+      -- We may need to reduce type famlies/synonyms in x's type first+      res <- pmTopNormaliseType (delta_ty_st delta) (idType x)+      let res_ty = normalisedSourceType res+      env <- dsGetFamInstEnvs+      case guessConLikeUnivTyArgsFromResTy env res_ty cl of+        Nothing      -> pure [delta] -- We can't split this one, so assume it's inhabited+        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 "split_at_con" (vcat [ ppr x+                                       , ppr new_tm_cs+                                       , ppr new_ty_cs+                                       , ppr strict_arg_tys+                                       , ppr delta+                                       , ppr mb_delta ])+          ev_pos <- case mb_delta of+            Nothing     -> pure []+            Just delta' -> go rec_ts (arg_vars ++ xs) n delta'++          -- Only n' more equations to go...+          let n' = n - length ev_pos+          ev_neg <- addRefutableAltCon delta x (PmAltConLike cl) >>= \case+            Nothing                          -> pure []+            Just delta'                      -> go rec_ts (x:xs) n' delta'++          -- Actually there was no need to split if we see that both branches+          -- were inhabited and we had no negative information on the variable!+          -- So only refine delta if we find that one branch was indeed+          -- uninhabited.+          let neg = lookupRefuts delta x+          case (ev_pos, ev_neg) of+            ([], _)       -> pure ev_neg+            (_, [])       -> pure ev_pos+            _ | null neg  -> pure [delta]+              | otherwise -> pure (ev_pos ++ ev_neg)++-- | Checks if every data con of the type 'isVanillaDataCon'.+isVanillaDataType :: Type -> Bool+isVanillaDataType ty = fromMaybe False $ do+  (tc, _) <- splitTyConApp_maybe ty+  dcs <- tyConDataCons_maybe tc+  pure (all isVanillaDataCon dcs)++-- | 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 (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/Regs.hs view
@@ -12,6 +12,7 @@ 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@@ -27,6 +28,7 @@  = case platformArch platform of    ArchX86    -> X86.callerSaves    ArchX86_64 -> X86_64.callerSaves+   ArchS390X  -> S390X.callerSaves    ArchSPARC  -> SPARC.callerSaves    ArchARM {} -> ARM.callerSaves    ArchARM64  -> ARM64.callerSaves@@ -48,6 +50,7 @@  = case platformArch platform of    ArchX86    -> X86.activeStgRegs    ArchX86_64 -> X86_64.activeStgRegs+   ArchS390X  -> S390X.activeStgRegs    ArchSPARC  -> SPARC.activeStgRegs    ArchARM {} -> ARM.activeStgRegs    ArchARM64  -> ARM64.activeStgRegs@@ -64,6 +67,7 @@  = case platformArch platform of    ArchX86    -> X86.haveRegBase    ArchX86_64 -> X86_64.haveRegBase+   ArchS390X  -> S390X.haveRegBase    ArchSPARC  -> SPARC.haveRegBase    ArchARM {} -> ARM.haveRegBase    ArchARM64  -> ARM64.haveRegBase@@ -80,6 +84,7 @@  = case platformArch platform of    ArchX86    -> X86.globalRegMaybe    ArchX86_64 -> X86_64.globalRegMaybe+   ArchS390X  -> S390X.globalRegMaybe    ArchSPARC  -> SPARC.globalRegMaybe    ArchARM {} -> ARM.globalRegMaybe    ArchARM64  -> ARM64.globalRegMaybe@@ -96,6 +101,7 @@  = case platformArch platform of    ArchX86    -> X86.freeReg    ArchX86_64 -> X86_64.freeReg+   ArchS390X  -> S390X.freeReg    ArchSPARC  -> SPARC.freeReg    ArchARM {} -> ARM.freeReg    ArchARM64  -> ARM64.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/StgToCmm.hs view
@@ -71,7 +71,7 @@         ; cgref <- liftIO $ newIORef =<< initC         ; let cg :: FCode () -> Stream IO CmmGroup ()               cg fcode = do-                cmm <- liftIO . withTimingSilent (return dflags) (text "STG -> Cmm") (`seq` ()) $ do+                cmm <- liftIO . withTimingSilent dflags (text "STG -> Cmm") (`seq` ()) $ do                          st <- readIORef cgref                          let (a,st') = runC dflags this_mod st (getCmm fcode)
compiler/GHC/StgToCmm/Bind.hs view
@@ -631,6 +631,7 @@              -- 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 []
compiler/GHC/StgToCmm/Closure.hs view
@@ -62,8 +62,6 @@         staticClosureNeedsLink,     ) where -#include "../includes/MachDeps.h"- #include "HsVersions.h"  import GhcPrelude
compiler/GHC/StgToCmm/Expr.hs view
@@ -576,7 +576,7 @@     arg_exprs <- getNonVoidArgAmodes stg_args     dflags <- getDynFlags     -- See Note [Inlining out-of-line primops and heap checks]-    return $! isJust $ shouldInlinePrimOp dflags op arg_exprs+    return $! shouldInlinePrimOp dflags op arg_exprs isSimpleOp (StgPrimCallOp _) _                           = return False  -----------------
compiler/GHC/StgToCmm/Prim.hs view
@@ -1,2626 +1,3008 @@ {-# LANGUAGE CPP #-}--#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 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]---- 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)--emitPrimOp _      [res] BRev8Op  [w] = emitBRevCall res w W8-emitPrimOp _      [res] BRev16Op [w] = emitBRevCall res w W16-emitPrimOp _      [res] BRev32Op [w] = emitBRevCall res w W32-emitPrimOp _      [res] BRev64Op [w] = emitBRevCall res w W64-emitPrimOp dflags [res] BRevOp   [w] = emitBRevCall 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 args of-          Left op   -> emit $ mkUnsafeCall (PrimTarget op) results args-          Right gen -> gen results args---- 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.--type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()--callishPrimOpSupported :: DynFlags -> PrimOp -> [CmmExpr] -> Either CallishMachOp GenericOp-callishPrimOpSupported dflags op args-  = case op of-      IntQuotRemOp   | ncg && (x86ish || ppc)-                     , not quotRemCanBeOptimized-                         -> Left (MO_S_QuotRem  (wordWidth dflags))-                     | otherwise-                         -> Right (genericIntQuotRemOp (wordWidth dflags))--      Int8QuotRemOp  | ncg && (x86ish || ppc)-                     , not quotRemCanBeOptimized-                                     -> Left (MO_S_QuotRem W8)-                     | otherwise     -> Right (genericIntQuotRemOp W8)--      Int16QuotRemOp | ncg && (x86ish || ppc)-                     , not quotRemCanBeOptimized-                                     -> Left (MO_S_QuotRem W16)-                     | otherwise     -> Right (genericIntQuotRemOp W16)---      WordQuotRemOp  | ncg && (x86ish || ppc)-                     , not quotRemCanBeOptimized-                         -> 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)-                     , not quotRemCanBeOptimized-                                      -> Left (MO_U_QuotRem W8)-                     | otherwise      -> Right (genericWordQuotRemOp W8)--      Word16QuotRemOp| ncg && (x86ish || ppc)-                     , not quotRemCanBeOptimized-                                     -> 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-  -- See Note [QuotRem optimization]-  quotRemCanBeOptimized = case args of-    [_, 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--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 DoubleLog1POp  = Just MO_F64_Log1P-callishOp DoubleExpOp    = Just MO_F64_Exp-callishOp DoubleExpM1Op  = Just MO_F64_ExpM1-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 FloatLog1POp  = Just MO_F32_Log1P-callishOp FloatExpOp    = Just MO_F32_Exp-callishOp FloatExpM1Op  = Just MO_F32_ExpM1-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 "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-       -- 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----- 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--        -- 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--        -- 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-    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 ]+{-# 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]++-- 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 emitPrimOp 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)++---------------------------------------------------+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+    Nothing -> panic "External prim op"+    Just f -> f results+++------------------------------------------------------------------------+--      Emitting code for a primop+------------------------------------------------------------------------++shouldInlinePrimOp :: DynFlags -> PrimOp -> [CmmExpr] -> Bool+shouldInlinePrimOp dflags op args = isJust $ emitPrimOp dflags op args++-- 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. The 'OpDest' function type+-- abstracts over a few common cases, and the "most manual" fallback.+--+-- 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.+dispatchPrimop+  :: DynFlags+  -> PrimOp            -- ^ The primop+  -> [CmmExpr]         -- ^ The primop arguments+  -> OpDest+dispatchPrimop dflags = \case+  NewByteArrayOp_Char -> \case+    [(CmmLit (CmmInt n w))]+      | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags)+      -> OpDest_AllDone  $ \ [res] -> doNewByteArrayOp res (fromInteger n)+    _ -> OpDest_External++  NewArrayOp -> \case+    [(CmmLit (CmmInt n w)), init]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> OpDest_AllDone $ \[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+    _ -> OpDest_External++  CopyArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      OpDest_AllDone $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)+    _ -> OpDest_External++  CopyMutableArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      OpDest_AllDone $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)+    _ -> OpDest_External++  CopyArrayArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      OpDest_AllDone $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)+    _ -> OpDest_External++  CopyMutableArrayArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      OpDest_AllDone $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)+    _ -> OpDest_External++  CloneArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> OpDest_AllDone $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+    _ -> OpDest_External++  CloneMutableArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> OpDest_AllDone $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)+    _ -> OpDest_External++  FreezeArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> OpDest_AllDone $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+    _ -> OpDest_External++  ThawArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> OpDest_AllDone $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)+    _ -> OpDest_External++  NewSmallArrayOp -> \case+    [(CmmLit (CmmInt n w)), init]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> OpDest_AllDone $ \ [res] ->+        doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel+        [ (mkIntExpr dflags (fromInteger n),+           fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags)+        ]+        (fromInteger n) init+    _ -> OpDest_External++  CopySmallArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      OpDest_AllDone $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n)+    _ -> OpDest_External++  CopySmallMutableArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      OpDest_AllDone $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n)+    _ -> OpDest_External++  CloneSmallArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> OpDest_AllDone $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+    _ -> OpDest_External++  CloneSmallMutableArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> OpDest_AllDone $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)+    _ -> OpDest_External++  FreezeSmallArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> OpDest_AllDone $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+    _ -> OpDest_External++  ThawSmallArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> OpDest_AllDone $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)+    _ -> OpDest_External++-- First we handle various awkward cases specially.++  ParOp -> \[arg] -> OpDest_AllDone $ \[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] -> OpDest_AllDone $ \[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] -> OpDest_AllDone $ \[res] -> do+    let+      val+       | gopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg)+       | otherwise                      = CmmLit (zeroCLit dflags)+    emitAssign (CmmLocal res) val++  GetCurrentCCSOp -> \[_] -> OpDest_AllDone $ \[res] -> do+    emitAssign (CmmLocal res) cccsExpr++  MyThreadIdOp -> \[] -> OpDest_AllDone $ \[res] -> do+    emitAssign (CmmLocal res) currentTSOExpr++  ReadMutVarOp -> \[mutv] -> OpDest_AllDone $ \[res] -> do+    emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))++  WriteMutVarOp -> \[mutv, var] -> OpDest_AllDone $ \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] -> OpDest_AllDone $ \[res] -> do+    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))++--  #define sizzeofMutableByteArrayzh(r,a) \+--      r = ((StgArrBytes *)(a))->bytes+  SizeofMutableByteArrayOp -> dispatchPrimop dflags SizeofByteArrayOp++--  #define getSizzeofMutableByteArrayzh(r,a) \+--      r = ((StgArrBytes *)(a))->bytes+  GetSizeofMutableByteArrayOp -> \[arg] -> OpDest_AllDone $ \[res] -> do+    emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))+++--  #define touchzh(o)                  /* nothing */+  TouchOp -> \args@[_] -> OpDest_AllDone $ \res@[] -> do+    emitPrimCall res MO_Touch args++--  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)+  ByteArrayContents_Char -> \[arg] -> OpDest_AllDone $ \[res] -> do+    emitAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags))++--  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)+  StableNameToIntOp -> \[arg] -> OpDest_AllDone $ \[res] -> do+    emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))++  ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> OpDest_AllDone $ \[res] -> do+    emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])++--  #define addrToHValuezh(r,a) r=(P_)a+  AddrToAnyOp -> \[arg] -> OpDest_AllDone $ \[res] -> do+    emitAssign (CmmLocal res) arg++--  #define hvalueToAddrzh(r, a) r=(W_)a+  AnyToAddrOp -> \[arg] -> OpDest_AllDone $ \[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] -> OpDest_AllDone $ \[res] -> do+    emit $ catAGraphs+      [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),+        mkAssign (CmmLocal res) arg ]+  UnsafeFreezeArrayArrayOp -> \[arg] -> OpDest_AllDone $ \[res] -> do+    emit $ catAGraphs+      [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),+        mkAssign (CmmLocal res) arg ]+  UnsafeFreezeSmallArrayOp -> \[arg] -> OpDest_AllDone $ \[res] -> do+    emit $ catAGraphs+      [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)),+        mkAssign (CmmLocal res) arg ]++--  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)+  UnsafeFreezeByteArrayOp -> \[arg] -> OpDest_AllDone $ \[res] -> do+    emitAssign (CmmLocal res) arg++-- Reading/writing pointer arrays++  ReadArrayOp -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  IndexArrayOp -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  WriteArrayOp -> \[obj, ix, v] -> OpDest_AllDone $ \[] -> do+    doWritePtrArrayOp obj ix v++  IndexArrayArrayOp_ByteArray -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  IndexArrayArrayOp_ArrayArray -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  ReadArrayArrayOp_ByteArray -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  ReadArrayArrayOp_MutableByteArray -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  ReadArrayArrayOp_ArrayArray -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  ReadArrayArrayOp_MutableArrayArray -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  WriteArrayArrayOp_ByteArray -> \[obj,ix,v] -> OpDest_AllDone $ \[] -> do+    doWritePtrArrayOp obj ix v+  WriteArrayArrayOp_MutableByteArray -> \[obj,ix,v] -> OpDest_AllDone $ \[] -> do+    doWritePtrArrayOp obj ix v+  WriteArrayArrayOp_ArrayArray -> \[obj,ix,v] -> OpDest_AllDone $ \[] -> do+    doWritePtrArrayOp obj ix v+  WriteArrayArrayOp_MutableArrayArray -> \[obj,ix,v] -> OpDest_AllDone $ \[] -> do+    doWritePtrArrayOp obj ix v++  ReadSmallArrayOp -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do+    doReadSmallPtrArrayOp res obj ix+  IndexSmallArrayOp -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do+    doReadSmallPtrArrayOp res obj ix+  WriteSmallArrayOp -> \[obj,ix,v] -> OpDest_AllDone $ \[] -> do+    doWriteSmallPtrArrayOp obj ix v++-- Getting the size of pointer arrays++  SizeofArrayOp -> \[arg] -> OpDest_AllDone $ \[res] -> do+    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg+      (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgMutArrPtrs_ptrs dflags))+        (bWord dflags))+  SizeofMutableArrayOp -> dispatchPrimop dflags SizeofArrayOp+  SizeofArrayArrayOp -> dispatchPrimop dflags SizeofArrayOp+  SizeofMutableArrayArrayOp -> dispatchPrimop dflags SizeofArrayOp+  SizeofSmallArrayOp -> \[arg] -> OpDest_AllDone $ \[res] -> do+    emit $ mkAssign (CmmLocal res)+     (cmmLoadIndexW dflags arg+     (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgSmallMutArrPtrs_ptrs dflags))+        (bWord dflags))++  SizeofSmallMutableArrayOp -> dispatchPrimop dflags SizeofSmallArrayOp+  GetSizeofSmallMutableArrayOp -> dispatchPrimop dflags SizeofSmallArrayOp++-- IndexXXXoffAddr++  IndexOffAddrOp_Char -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args+  IndexOffAddrOp_WideChar -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+  IndexOffAddrOp_Int -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  IndexOffAddrOp_Word -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  IndexOffAddrOp_Addr -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  IndexOffAddrOp_Float -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   Nothing f32 res args+  IndexOffAddrOp_Double -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   Nothing f64 res args+  IndexOffAddrOp_StablePtr -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  IndexOffAddrOp_Int8 -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args+  IndexOffAddrOp_Int16 -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args+  IndexOffAddrOp_Int32 -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args+  IndexOffAddrOp_Int64 -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   Nothing b64 res args+  IndexOffAddrOp_Word8 -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args+  IndexOffAddrOp_Word16 -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args+  IndexOffAddrOp_Word32 -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+  IndexOffAddrOp_Word64 -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   Nothing b64 res args++-- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.++  ReadOffAddrOp_Char -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args+  ReadOffAddrOp_WideChar -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+  ReadOffAddrOp_Int -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  ReadOffAddrOp_Word -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  ReadOffAddrOp_Addr -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  ReadOffAddrOp_Float -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   Nothing f32 res args+  ReadOffAddrOp_Double -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   Nothing f64 res args+  ReadOffAddrOp_StablePtr -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  ReadOffAddrOp_Int8 -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args+  ReadOffAddrOp_Int16 -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args+  ReadOffAddrOp_Int32 -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args+  ReadOffAddrOp_Int64 -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   Nothing b64 res args+  ReadOffAddrOp_Word8 -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args+  ReadOffAddrOp_Word16 -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args+  ReadOffAddrOp_Word32 -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+  ReadOffAddrOp_Word64 -> \args -> OpDest_AllDone $ \res -> do+    doIndexOffAddrOp   Nothing b64 res args++-- IndexXXXArray++  IndexByteArrayOp_Char -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args+  IndexByteArrayOp_WideChar -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args+  IndexByteArrayOp_Int -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  IndexByteArrayOp_Word -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  IndexByteArrayOp_Addr -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  IndexByteArrayOp_Float -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   Nothing f32 res args+  IndexByteArrayOp_Double -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   Nothing f64 res args+  IndexByteArrayOp_StablePtr -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  IndexByteArrayOp_Int8 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args+  IndexByteArrayOp_Int16 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args+  IndexByteArrayOp_Int32 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args+  IndexByteArrayOp_Int64 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   Nothing b64  res args+  IndexByteArrayOp_Word8 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args+  IndexByteArrayOp_Word16 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args+  IndexByteArrayOp_Word32 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args+  IndexByteArrayOp_Word64 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   Nothing b64  res args++-- ReadXXXArray, identical to IndexXXXArray.++  ReadByteArrayOp_Char -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args+  ReadByteArrayOp_WideChar -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args+  ReadByteArrayOp_Int -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  ReadByteArrayOp_Word -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  ReadByteArrayOp_Addr -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  ReadByteArrayOp_Float -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   Nothing f32 res args+  ReadByteArrayOp_Double -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   Nothing f64 res args+  ReadByteArrayOp_StablePtr -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  ReadByteArrayOp_Int8 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args+  ReadByteArrayOp_Int16 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args+  ReadByteArrayOp_Int32 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args+  ReadByteArrayOp_Int64 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   Nothing b64  res args+  ReadByteArrayOp_Word8 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args+  ReadByteArrayOp_Word16 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args+  ReadByteArrayOp_Word32 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args+  ReadByteArrayOp_Word64 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOp   Nothing b64  res args++-- IndexWord8ArrayAsXXX++  IndexByteArrayOp_Word8AsChar -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args+  IndexByteArrayOp_Word8AsWideChar -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+  IndexByteArrayOp_Word8AsInt -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  IndexByteArrayOp_Word8AsWord -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  IndexByteArrayOp_Word8AsAddr -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  IndexByteArrayOp_Word8AsFloat -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing f32 b8 res args+  IndexByteArrayOp_Word8AsDouble -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing f64 b8 res args+  IndexByteArrayOp_Word8AsStablePtr -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  IndexByteArrayOp_Word8AsInt16 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args+  IndexByteArrayOp_Word8AsInt32 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args+  IndexByteArrayOp_Word8AsInt64 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing b64 b8 res args+  IndexByteArrayOp_Word8AsWord16 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args+  IndexByteArrayOp_Word8AsWord32 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+  IndexByteArrayOp_Word8AsWord64 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing b64 b8 res args++-- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX++  ReadByteArrayOp_Word8AsChar -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args+  ReadByteArrayOp_Word8AsWideChar -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+  ReadByteArrayOp_Word8AsInt -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  ReadByteArrayOp_Word8AsWord -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  ReadByteArrayOp_Word8AsAddr -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  ReadByteArrayOp_Word8AsFloat -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing f32 b8 res args+  ReadByteArrayOp_Word8AsDouble -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing f64 b8 res args+  ReadByteArrayOp_Word8AsStablePtr -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  ReadByteArrayOp_Word8AsInt16 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args+  ReadByteArrayOp_Word8AsInt32 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args+  ReadByteArrayOp_Word8AsInt64 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing b64 b8 res args+  ReadByteArrayOp_Word8AsWord16 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args+  ReadByteArrayOp_Word8AsWord32 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+  ReadByteArrayOp_Word8AsWord64 -> \args -> OpDest_AllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing b64 b8 res args++-- WriteXXXoffAddr++  WriteOffAddrOp_Char -> \args -> OpDest_AllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args+  WriteOffAddrOp_WideChar -> \args -> OpDest_AllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args+  WriteOffAddrOp_Int -> \args -> OpDest_AllDone $ \res -> do+    doWriteOffAddrOp Nothing (bWord dflags) res args+  WriteOffAddrOp_Word -> \args -> OpDest_AllDone $ \res -> do+    doWriteOffAddrOp Nothing (bWord dflags) res args+  WriteOffAddrOp_Addr -> \args -> OpDest_AllDone $ \res -> do+    doWriteOffAddrOp Nothing (bWord dflags) res args+  WriteOffAddrOp_Float -> \args -> OpDest_AllDone $ \res -> do+    doWriteOffAddrOp Nothing f32 res args+  WriteOffAddrOp_Double -> \args -> OpDest_AllDone $ \res -> do+    doWriteOffAddrOp Nothing f64 res args+  WriteOffAddrOp_StablePtr -> \args -> OpDest_AllDone $ \res -> do+    doWriteOffAddrOp Nothing (bWord dflags) res args+  WriteOffAddrOp_Int8 -> \args -> OpDest_AllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args+  WriteOffAddrOp_Int16 -> \args -> OpDest_AllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args+  WriteOffAddrOp_Int32 -> \args -> OpDest_AllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args+  WriteOffAddrOp_Int64 -> \args -> OpDest_AllDone $ \res -> do+    doWriteOffAddrOp Nothing b64 res args+  WriteOffAddrOp_Word8 -> \args -> OpDest_AllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args+  WriteOffAddrOp_Word16 -> \args -> OpDest_AllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args+  WriteOffAddrOp_Word32 -> \args -> OpDest_AllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args+  WriteOffAddrOp_Word64 -> \args -> OpDest_AllDone $ \res -> do+    doWriteOffAddrOp Nothing b64 res args++-- WriteXXXArray++  WriteByteArrayOp_Char -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args+  WriteByteArrayOp_WideChar -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args+  WriteByteArrayOp_Int -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp Nothing (bWord dflags) res args+  WriteByteArrayOp_Word -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp Nothing (bWord dflags) res args+  WriteByteArrayOp_Addr -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp Nothing (bWord dflags) res args+  WriteByteArrayOp_Float -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp Nothing f32 res args+  WriteByteArrayOp_Double -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp Nothing f64 res args+  WriteByteArrayOp_StablePtr -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp Nothing (bWord dflags) res args+  WriteByteArrayOp_Int8 -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args+  WriteByteArrayOp_Int16 -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args+  WriteByteArrayOp_Int32 -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args+  WriteByteArrayOp_Int64 -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp Nothing b64 res args+  WriteByteArrayOp_Word8 -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8  res args+  WriteByteArrayOp_Word16 -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args+  WriteByteArrayOp_Word32 -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args+  WriteByteArrayOp_Word64 -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp Nothing b64 res args++-- WriteInt8ArrayAsXXX++  WriteByteArrayOp_Word8AsChar -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args+  WriteByteArrayOp_Word8AsWideChar -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args+  WriteByteArrayOp_Word8AsInt -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsWord -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsAddr -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsFloat -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsDouble -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsStablePtr -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsInt16 -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args+  WriteByteArrayOp_Word8AsInt32 -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args+  WriteByteArrayOp_Word8AsInt64 -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsWord16 -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args+  WriteByteArrayOp_Word8AsWord32 -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args+  WriteByteArrayOp_Word8AsWord64 -> \args -> OpDest_AllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args++-- Copying and setting byte arrays+  CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> OpDest_AllDone $ \[] -> do+    doCopyByteArrayOp src src_off dst dst_off n+  CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> OpDest_AllDone $ \[] -> do+    doCopyMutableByteArrayOp src src_off dst dst_off n+  CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> OpDest_AllDone $ \[] -> do+    doCopyByteArrayToAddrOp src src_off dst n+  CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> OpDest_AllDone $ \[] -> do+    doCopyMutableByteArrayToAddrOp src src_off dst n+  CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> OpDest_AllDone $ \[] -> do+    doCopyAddrToByteArrayOp src dst dst_off n+  SetByteArrayOp -> \[ba,off,len,c] -> OpDest_AllDone $ \[] -> do+    doSetByteArrayOp ba off len c++-- Comparing byte arrays+  CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> OpDest_AllDone $ \[res] -> do+    doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n++  BSwap16Op -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitBSwapCall res w W16+  BSwap32Op -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitBSwapCall res w W32+  BSwap64Op -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitBSwapCall res w W64+  BSwapOp -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitBSwapCall res w (wordWidth dflags)++  BRev8Op -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitBRevCall res w W8+  BRev16Op -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitBRevCall res w W16+  BRev32Op -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitBRevCall res w W32+  BRev64Op -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitBRevCall res w W64+  BRevOp -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitBRevCall res w (wordWidth dflags)++-- Population count+  PopCnt8Op -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitPopCntCall res w W8+  PopCnt16Op -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitPopCntCall res w W16+  PopCnt32Op -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitPopCntCall res w W32+  PopCnt64Op -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitPopCntCall res w W64+  PopCntOp -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitPopCntCall res w (wordWidth dflags)++-- Parallel bit deposit+  Pdep8Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do+    emitPdepCall res src mask W8+  Pdep16Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do+    emitPdepCall res src mask W16+  Pdep32Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do+    emitPdepCall res src mask W32+  Pdep64Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do+    emitPdepCall res src mask W64+  PdepOp -> \[src, mask] -> OpDest_AllDone $ \[res] -> do+    emitPdepCall res src mask (wordWidth dflags)++-- Parallel bit extract+  Pext8Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do+    emitPextCall res src mask W8+  Pext16Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do+    emitPextCall res src mask W16+  Pext32Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do+    emitPextCall res src mask W32+  Pext64Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do+    emitPextCall res src mask W64+  PextOp -> \[src, mask] -> OpDest_AllDone $ \[res] -> do+    emitPextCall res src mask (wordWidth dflags)++-- count leading zeros+  Clz8Op -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitClzCall res w W8+  Clz16Op -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitClzCall res w W16+  Clz32Op -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitClzCall res w W32+  Clz64Op -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitClzCall res w W64+  ClzOp -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitClzCall res w (wordWidth dflags)++-- count trailing zeros+  Ctz8Op -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitCtzCall res w W8+  Ctz16Op -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitCtzCall res w W16+  Ctz32Op -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitCtzCall res w W32+  Ctz64Op -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitCtzCall res w W64+  CtzOp -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitCtzCall res w (wordWidth dflags)++-- Unsigned int to floating point conversions+  Word2FloatOp -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitPrimCall [res] (MO_UF_Conv W32) [w]+  Word2DoubleOp -> \[w] -> OpDest_AllDone $ \[res] -> do+    emitPrimCall [res] (MO_UF_Conv W64) [w]++-- SIMD primops+  (VecBroadcastOp vcat n w) -> \[e] -> OpDest_AllDone $ \[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 -> OpDest_AllDone $ \[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] -> OpDest_AllDone $ \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] -> OpDest_AllDone $ \[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 -> OpDest_AllDone $ \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 -> OpDest_AllDone $ \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 -> OpDest_AllDone $ \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 -> OpDest_AllDone $ \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 -> OpDest_AllDone $ \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 -> OpDest_AllDone $ \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 -> OpDest_AllDone $ \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 -> OpDest_AllDone $ \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 -> OpDest_AllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doWriteByteArrayOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecCmmCat vcat w++  (VecIndexScalarOffAddrOp vcat n w) -> \args -> OpDest_AllDone $ \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 -> OpDest_AllDone $ \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 -> OpDest_AllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doWriteOffAddrOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecCmmCat vcat w++-- Prefetch+  PrefetchByteArrayOp3         -> \args -> OpDest_AllDone $ \[] -> do+    doPrefetchByteArrayOp 3  args+  PrefetchMutableByteArrayOp3  -> \args -> OpDest_AllDone $ \[] -> do+    doPrefetchMutableByteArrayOp 3  args+  PrefetchAddrOp3              -> \args -> OpDest_AllDone $ \[] -> do+    doPrefetchAddrOp  3  args+  PrefetchValueOp3             -> \args -> OpDest_AllDone $ \[] -> do+    doPrefetchValueOp 3 args++  PrefetchByteArrayOp2         -> \args -> OpDest_AllDone $ \[] -> do+    doPrefetchByteArrayOp 2  args+  PrefetchMutableByteArrayOp2  -> \args -> OpDest_AllDone $ \[] -> do+    doPrefetchMutableByteArrayOp 2  args+  PrefetchAddrOp2              -> \args -> OpDest_AllDone $ \[] -> do+    doPrefetchAddrOp 2  args+  PrefetchValueOp2             -> \args -> OpDest_AllDone $ \[] -> do+    doPrefetchValueOp 2 args+  PrefetchByteArrayOp1         -> \args -> OpDest_AllDone $ \[] -> do+    doPrefetchByteArrayOp 1  args+  PrefetchMutableByteArrayOp1  -> \args -> OpDest_AllDone $ \[] -> do+    doPrefetchMutableByteArrayOp 1  args+  PrefetchAddrOp1              -> \args -> OpDest_AllDone $ \[] -> do+    doPrefetchAddrOp 1  args+  PrefetchValueOp1             -> \args -> OpDest_AllDone $ \[] -> do+    doPrefetchValueOp 1 args++  PrefetchByteArrayOp0         -> \args -> OpDest_AllDone $ \[] -> do+    doPrefetchByteArrayOp 0  args+  PrefetchMutableByteArrayOp0  -> \args -> OpDest_AllDone $ \[] -> do+    doPrefetchMutableByteArrayOp 0  args+  PrefetchAddrOp0              -> \args -> OpDest_AllDone $ \[] -> do+    doPrefetchAddrOp 0  args+  PrefetchValueOp0             -> \args -> OpDest_AllDone $ \[] -> do+    doPrefetchValueOp 0 args++-- Atomic read-modify-write+  FetchAddByteArrayOp_Int -> \[mba, ix, n] -> OpDest_AllDone $ \[res] -> do+    doAtomicRMW res AMO_Add mba ix (bWord dflags) n+  FetchSubByteArrayOp_Int -> \[mba, ix, n] -> OpDest_AllDone $ \[res] -> do+    doAtomicRMW res AMO_Sub mba ix (bWord dflags) n+  FetchAndByteArrayOp_Int -> \[mba, ix, n] -> OpDest_AllDone $ \[res] -> do+    doAtomicRMW res AMO_And mba ix (bWord dflags) n+  FetchNandByteArrayOp_Int -> \[mba, ix, n] -> OpDest_AllDone $ \[res] -> do+    doAtomicRMW res AMO_Nand mba ix (bWord dflags) n+  FetchOrByteArrayOp_Int -> \[mba, ix, n] -> OpDest_AllDone $ \[res] -> do+    doAtomicRMW res AMO_Or mba ix (bWord dflags) n+  FetchXorByteArrayOp_Int -> \[mba, ix, n] -> OpDest_AllDone $ \[res] -> do+    doAtomicRMW res AMO_Xor mba ix (bWord dflags) n+  AtomicReadByteArrayOp_Int -> \[mba, ix] -> OpDest_AllDone $ \[res] -> do+    doAtomicReadByteArray res mba ix (bWord dflags)+  AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> OpDest_AllDone $ \[] -> do+    doAtomicWriteByteArray mba ix (bWord dflags) val+  CasByteArrayOp_Int -> \[mba, ix, old, new] -> OpDest_AllDone $ \[res] -> do+    doCasByteArray res mba ix (bWord dflags) old new++-- The rest just translate straightforwardly++  Int2WordOp      -> \_ -> OpDest_Nop+  Word2IntOp      -> \_ -> OpDest_Nop+  Int2AddrOp      -> \_ -> OpDest_Nop+  Addr2IntOp      -> \_ -> OpDest_Nop+  ChrOp           -> \_ -> OpDest_Nop  -- Int# and Char# are rep'd the same+  OrdOp           -> \_ -> OpDest_Nop++  Narrow8IntOp   -> \_ -> OpDest_Narrow (MO_SS_Conv, W8)+  Narrow16IntOp  -> \_ -> OpDest_Narrow (MO_SS_Conv, W16)+  Narrow32IntOp  -> \_ -> OpDest_Narrow (MO_SS_Conv, W32)+  Narrow8WordOp  -> \_ -> OpDest_Narrow (MO_UU_Conv, W8)+  Narrow16WordOp -> \_ -> OpDest_Narrow (MO_UU_Conv, W16)+  Narrow32WordOp -> \_ -> OpDest_Narrow (MO_UU_Conv, W32)++  DoublePowerOp  -> \_ -> OpDest_Callish MO_F64_Pwr+  DoubleSinOp    -> \_ -> OpDest_Callish MO_F64_Sin+  DoubleCosOp    -> \_ -> OpDest_Callish MO_F64_Cos+  DoubleTanOp    -> \_ -> OpDest_Callish MO_F64_Tan+  DoubleSinhOp   -> \_ -> OpDest_Callish MO_F64_Sinh+  DoubleCoshOp   -> \_ -> OpDest_Callish MO_F64_Cosh+  DoubleTanhOp   -> \_ -> OpDest_Callish MO_F64_Tanh+  DoubleAsinOp   -> \_ -> OpDest_Callish MO_F64_Asin+  DoubleAcosOp   -> \_ -> OpDest_Callish MO_F64_Acos+  DoubleAtanOp   -> \_ -> OpDest_Callish MO_F64_Atan+  DoubleAsinhOp  -> \_ -> OpDest_Callish MO_F64_Asinh+  DoubleAcoshOp  -> \_ -> OpDest_Callish MO_F64_Acosh+  DoubleAtanhOp  -> \_ -> OpDest_Callish MO_F64_Atanh+  DoubleLogOp    -> \_ -> OpDest_Callish MO_F64_Log+  DoubleLog1POp  -> \_ -> OpDest_Callish MO_F64_Log1P+  DoubleExpOp    -> \_ -> OpDest_Callish MO_F64_Exp+  DoubleExpM1Op  -> \_ -> OpDest_Callish MO_F64_ExpM1+  DoubleSqrtOp   -> \_ -> OpDest_Callish MO_F64_Sqrt++  FloatPowerOp   -> \_ -> OpDest_Callish MO_F32_Pwr+  FloatSinOp     -> \_ -> OpDest_Callish MO_F32_Sin+  FloatCosOp     -> \_ -> OpDest_Callish MO_F32_Cos+  FloatTanOp     -> \_ -> OpDest_Callish MO_F32_Tan+  FloatSinhOp    -> \_ -> OpDest_Callish MO_F32_Sinh+  FloatCoshOp    -> \_ -> OpDest_Callish MO_F32_Cosh+  FloatTanhOp    -> \_ -> OpDest_Callish MO_F32_Tanh+  FloatAsinOp    -> \_ -> OpDest_Callish MO_F32_Asin+  FloatAcosOp    -> \_ -> OpDest_Callish MO_F32_Acos+  FloatAtanOp    -> \_ -> OpDest_Callish MO_F32_Atan+  FloatAsinhOp   -> \_ -> OpDest_Callish MO_F32_Asinh+  FloatAcoshOp   -> \_ -> OpDest_Callish MO_F32_Acosh+  FloatAtanhOp   -> \_ -> OpDest_Callish MO_F32_Atanh+  FloatLogOp     -> \_ -> OpDest_Callish MO_F32_Log+  FloatLog1POp   -> \_ -> OpDest_Callish MO_F32_Log1P+  FloatExpOp     -> \_ -> OpDest_Callish MO_F32_Exp+  FloatExpM1Op   -> \_ -> OpDest_Callish MO_F32_ExpM1+  FloatSqrtOp    -> \_ -> OpDest_Callish MO_F32_Sqrt++-- Native word signless ops++  IntAddOp       -> \_ -> OpDest_Translate (mo_wordAdd dflags)+  IntSubOp       -> \_ -> OpDest_Translate (mo_wordSub dflags)+  WordAddOp      -> \_ -> OpDest_Translate (mo_wordAdd dflags)+  WordSubOp      -> \_ -> OpDest_Translate (mo_wordSub dflags)+  AddrAddOp      -> \_ -> OpDest_Translate (mo_wordAdd dflags)+  AddrSubOp      -> \_ -> OpDest_Translate (mo_wordSub dflags)++  IntEqOp        -> \_ -> OpDest_Translate (mo_wordEq dflags)+  IntNeOp        -> \_ -> OpDest_Translate (mo_wordNe dflags)+  WordEqOp       -> \_ -> OpDest_Translate (mo_wordEq dflags)+  WordNeOp       -> \_ -> OpDest_Translate (mo_wordNe dflags)+  AddrEqOp       -> \_ -> OpDest_Translate (mo_wordEq dflags)+  AddrNeOp       -> \_ -> OpDest_Translate (mo_wordNe dflags)++  AndOp          -> \_ -> OpDest_Translate (mo_wordAnd dflags)+  OrOp           -> \_ -> OpDest_Translate (mo_wordOr dflags)+  XorOp          -> \_ -> OpDest_Translate (mo_wordXor dflags)+  NotOp          -> \_ -> OpDest_Translate (mo_wordNot dflags)+  SllOp          -> \_ -> OpDest_Translate (mo_wordShl dflags)+  SrlOp          -> \_ -> OpDest_Translate (mo_wordUShr dflags)++  AddrRemOp      -> \_ -> OpDest_Translate (mo_wordURem dflags)++-- Native word signed ops++  IntMulOp        -> \_ -> OpDest_Translate (mo_wordMul dflags)+  IntMulMayOfloOp -> \_ -> OpDest_Translate (MO_S_MulMayOflo (wordWidth dflags))+  IntQuotOp       -> \_ -> OpDest_Translate (mo_wordSQuot dflags)+  IntRemOp        -> \_ -> OpDest_Translate (mo_wordSRem dflags)+  IntNegOp        -> \_ -> OpDest_Translate (mo_wordSNeg dflags)++  IntGeOp        -> \_ -> OpDest_Translate (mo_wordSGe dflags)+  IntLeOp        -> \_ -> OpDest_Translate (mo_wordSLe dflags)+  IntGtOp        -> \_ -> OpDest_Translate (mo_wordSGt dflags)+  IntLtOp        -> \_ -> OpDest_Translate (mo_wordSLt dflags)++  AndIOp         -> \_ -> OpDest_Translate (mo_wordAnd dflags)+  OrIOp          -> \_ -> OpDest_Translate (mo_wordOr dflags)+  XorIOp         -> \_ -> OpDest_Translate (mo_wordXor dflags)+  NotIOp         -> \_ -> OpDest_Translate (mo_wordNot dflags)+  ISllOp         -> \_ -> OpDest_Translate (mo_wordShl dflags)+  ISraOp         -> \_ -> OpDest_Translate (mo_wordSShr dflags)+  ISrlOp         -> \_ -> OpDest_Translate (mo_wordUShr dflags)++-- Native word unsigned ops++  WordGeOp       -> \_ -> OpDest_Translate (mo_wordUGe dflags)+  WordLeOp       -> \_ -> OpDest_Translate (mo_wordULe dflags)+  WordGtOp       -> \_ -> OpDest_Translate (mo_wordUGt dflags)+  WordLtOp       -> \_ -> OpDest_Translate (mo_wordULt dflags)++  WordMulOp      -> \_ -> OpDest_Translate (mo_wordMul dflags)+  WordQuotOp     -> \_ -> OpDest_Translate (mo_wordUQuot dflags)+  WordRemOp      -> \_ -> OpDest_Translate (mo_wordURem dflags)++  AddrGeOp       -> \_ -> OpDest_Translate (mo_wordUGe dflags)+  AddrLeOp       -> \_ -> OpDest_Translate (mo_wordULe dflags)+  AddrGtOp       -> \_ -> OpDest_Translate (mo_wordUGt dflags)+  AddrLtOp       -> \_ -> OpDest_Translate (mo_wordULt dflags)++-- Int8# signed ops++  Int8Extend     -> \_ -> OpDest_Translate (MO_SS_Conv W8 (wordWidth dflags))+  Int8Narrow     -> \_ -> OpDest_Translate (MO_SS_Conv (wordWidth dflags) W8)+  Int8NegOp      -> \_ -> OpDest_Translate (MO_S_Neg W8)+  Int8AddOp      -> \_ -> OpDest_Translate (MO_Add W8)+  Int8SubOp      -> \_ -> OpDest_Translate (MO_Sub W8)+  Int8MulOp      -> \_ -> OpDest_Translate (MO_Mul W8)+  Int8QuotOp     -> \_ -> OpDest_Translate (MO_S_Quot W8)+  Int8RemOp      -> \_ -> OpDest_Translate (MO_S_Rem W8)++  Int8EqOp       -> \_ -> OpDest_Translate (MO_Eq W8)+  Int8GeOp       -> \_ -> OpDest_Translate (MO_S_Ge W8)+  Int8GtOp       -> \_ -> OpDest_Translate (MO_S_Gt W8)+  Int8LeOp       -> \_ -> OpDest_Translate (MO_S_Le W8)+  Int8LtOp       -> \_ -> OpDest_Translate (MO_S_Lt W8)+  Int8NeOp       -> \_ -> OpDest_Translate (MO_Ne W8)++-- Word8# unsigned ops++  Word8Extend     -> \_ -> OpDest_Translate (MO_UU_Conv W8 (wordWidth dflags))+  Word8Narrow     -> \_ -> OpDest_Translate (MO_UU_Conv (wordWidth dflags) W8)+  Word8NotOp      -> \_ -> OpDest_Translate (MO_Not W8)+  Word8AddOp      -> \_ -> OpDest_Translate (MO_Add W8)+  Word8SubOp      -> \_ -> OpDest_Translate (MO_Sub W8)+  Word8MulOp      -> \_ -> OpDest_Translate (MO_Mul W8)+  Word8QuotOp     -> \_ -> OpDest_Translate (MO_U_Quot W8)+  Word8RemOp      -> \_ -> OpDest_Translate (MO_U_Rem W8)++  Word8EqOp       -> \_ -> OpDest_Translate (MO_Eq W8)+  Word8GeOp       -> \_ -> OpDest_Translate (MO_U_Ge W8)+  Word8GtOp       -> \_ -> OpDest_Translate (MO_U_Gt W8)+  Word8LeOp       -> \_ -> OpDest_Translate (MO_U_Le W8)+  Word8LtOp       -> \_ -> OpDest_Translate (MO_U_Lt W8)+  Word8NeOp       -> \_ -> OpDest_Translate (MO_Ne W8)++-- Int16# signed ops++  Int16Extend     -> \_ -> OpDest_Translate (MO_SS_Conv W16 (wordWidth dflags))+  Int16Narrow     -> \_ -> OpDest_Translate (MO_SS_Conv (wordWidth dflags) W16)+  Int16NegOp      -> \_ -> OpDest_Translate (MO_S_Neg W16)+  Int16AddOp      -> \_ -> OpDest_Translate (MO_Add W16)+  Int16SubOp      -> \_ -> OpDest_Translate (MO_Sub W16)+  Int16MulOp      -> \_ -> OpDest_Translate (MO_Mul W16)+  Int16QuotOp     -> \_ -> OpDest_Translate (MO_S_Quot W16)+  Int16RemOp      -> \_ -> OpDest_Translate (MO_S_Rem W16)++  Int16EqOp       -> \_ -> OpDest_Translate (MO_Eq W16)+  Int16GeOp       -> \_ -> OpDest_Translate (MO_S_Ge W16)+  Int16GtOp       -> \_ -> OpDest_Translate (MO_S_Gt W16)+  Int16LeOp       -> \_ -> OpDest_Translate (MO_S_Le W16)+  Int16LtOp       -> \_ -> OpDest_Translate (MO_S_Lt W16)+  Int16NeOp       -> \_ -> OpDest_Translate (MO_Ne W16)++-- Word16# unsigned ops++  Word16Extend     -> \_ -> OpDest_Translate (MO_UU_Conv W16 (wordWidth dflags))+  Word16Narrow     -> \_ -> OpDest_Translate (MO_UU_Conv (wordWidth dflags) W16)+  Word16NotOp      -> \_ -> OpDest_Translate (MO_Not W16)+  Word16AddOp      -> \_ -> OpDest_Translate (MO_Add W16)+  Word16SubOp      -> \_ -> OpDest_Translate (MO_Sub W16)+  Word16MulOp      -> \_ -> OpDest_Translate (MO_Mul W16)+  Word16QuotOp     -> \_ -> OpDest_Translate (MO_U_Quot W16)+  Word16RemOp      -> \_ -> OpDest_Translate (MO_U_Rem W16)++  Word16EqOp       -> \_ -> OpDest_Translate (MO_Eq W16)+  Word16GeOp       -> \_ -> OpDest_Translate (MO_U_Ge W16)+  Word16GtOp       -> \_ -> OpDest_Translate (MO_U_Gt W16)+  Word16LeOp       -> \_ -> OpDest_Translate (MO_U_Le W16)+  Word16LtOp       -> \_ -> OpDest_Translate (MO_U_Lt W16)+  Word16NeOp       -> \_ -> OpDest_Translate (MO_Ne W16)++-- Char# ops++  CharEqOp       -> \_ -> OpDest_Translate (MO_Eq (wordWidth dflags))+  CharNeOp       -> \_ -> OpDest_Translate (MO_Ne (wordWidth dflags))+  CharGeOp       -> \_ -> OpDest_Translate (MO_U_Ge (wordWidth dflags))+  CharLeOp       -> \_ -> OpDest_Translate (MO_U_Le (wordWidth dflags))+  CharGtOp       -> \_ -> OpDest_Translate (MO_U_Gt (wordWidth dflags))+  CharLtOp       -> \_ -> OpDest_Translate (MO_U_Lt (wordWidth dflags))++-- Double ops++  DoubleEqOp     -> \_ -> OpDest_Translate (MO_F_Eq W64)+  DoubleNeOp     -> \_ -> OpDest_Translate (MO_F_Ne W64)+  DoubleGeOp     -> \_ -> OpDest_Translate (MO_F_Ge W64)+  DoubleLeOp     -> \_ -> OpDest_Translate (MO_F_Le W64)+  DoubleGtOp     -> \_ -> OpDest_Translate (MO_F_Gt W64)+  DoubleLtOp     -> \_ -> OpDest_Translate (MO_F_Lt W64)++  DoubleAddOp    -> \_ -> OpDest_Translate (MO_F_Add W64)+  DoubleSubOp    -> \_ -> OpDest_Translate (MO_F_Sub W64)+  DoubleMulOp    -> \_ -> OpDest_Translate (MO_F_Mul W64)+  DoubleDivOp    -> \_ -> OpDest_Translate (MO_F_Quot W64)+  DoubleNegOp    -> \_ -> OpDest_Translate (MO_F_Neg W64)++-- Float ops++  FloatEqOp     -> \_ -> OpDest_Translate (MO_F_Eq W32)+  FloatNeOp     -> \_ -> OpDest_Translate (MO_F_Ne W32)+  FloatGeOp     -> \_ -> OpDest_Translate (MO_F_Ge W32)+  FloatLeOp     -> \_ -> OpDest_Translate (MO_F_Le W32)+  FloatGtOp     -> \_ -> OpDest_Translate (MO_F_Gt W32)+  FloatLtOp     -> \_ -> OpDest_Translate (MO_F_Lt W32)++  FloatAddOp    -> \_ -> OpDest_Translate (MO_F_Add  W32)+  FloatSubOp    -> \_ -> OpDest_Translate (MO_F_Sub  W32)+  FloatMulOp    -> \_ -> OpDest_Translate (MO_F_Mul  W32)+  FloatDivOp    -> \_ -> OpDest_Translate (MO_F_Quot W32)+  FloatNegOp    -> \_ -> OpDest_Translate (MO_F_Neg  W32)++-- Vector ops++  (VecAddOp  FloatVec n w) -> \_ -> OpDest_Translate (MO_VF_Add  n w)+  (VecSubOp  FloatVec n w) -> \_ -> OpDest_Translate (MO_VF_Sub  n w)+  (VecMulOp  FloatVec n w) -> \_ -> OpDest_Translate (MO_VF_Mul  n w)+  (VecDivOp  FloatVec n w) -> \_ -> OpDest_Translate (MO_VF_Quot n w)+  (VecQuotOp FloatVec _ _) -> \_ -> panic "unsupported primop"+  (VecRemOp  FloatVec _ _) -> \_ -> panic "unsupported primop"+  (VecNegOp  FloatVec n w) -> \_ -> OpDest_Translate (MO_VF_Neg  n w)++  (VecAddOp  IntVec n w) -> \_ -> OpDest_Translate (MO_V_Add   n w)+  (VecSubOp  IntVec n w) -> \_ -> OpDest_Translate (MO_V_Sub   n w)+  (VecMulOp  IntVec n w) -> \_ -> OpDest_Translate (MO_V_Mul   n w)+  (VecDivOp  IntVec _ _) -> \_ -> panic "unsupported primop"+  (VecQuotOp IntVec n w) -> \_ -> OpDest_Translate (MO_VS_Quot n w)+  (VecRemOp  IntVec n w) -> \_ -> OpDest_Translate (MO_VS_Rem  n w)+  (VecNegOp  IntVec n w) -> \_ -> OpDest_Translate (MO_VS_Neg  n w)++  (VecAddOp  WordVec n w) -> \_ -> OpDest_Translate (MO_V_Add   n w)+  (VecSubOp  WordVec n w) -> \_ -> OpDest_Translate (MO_V_Sub   n w)+  (VecMulOp  WordVec n w) -> \_ -> OpDest_Translate (MO_V_Mul   n w)+  (VecDivOp  WordVec _ _) -> \_ -> panic "unsupported primop"+  (VecQuotOp WordVec n w) -> \_ -> OpDest_Translate (MO_VU_Quot n w)+  (VecRemOp  WordVec n w) -> \_ -> OpDest_Translate (MO_VU_Rem  n w)+  (VecNegOp  WordVec _ _) -> \_ -> panic "unsupported primop"++-- Conversions++  Int2DoubleOp   -> \_ -> OpDest_Translate (MO_SF_Conv (wordWidth dflags) W64)+  Double2IntOp   -> \_ -> OpDest_Translate (MO_FS_Conv W64 (wordWidth dflags))++  Int2FloatOp    -> \_ -> OpDest_Translate (MO_SF_Conv (wordWidth dflags) W32)+  Float2IntOp    -> \_ -> OpDest_Translate (MO_FS_Conv W32 (wordWidth dflags))++  Float2DoubleOp -> \_ -> OpDest_Translate (MO_FF_Conv W32 W64)+  Double2FloatOp -> \_ -> OpDest_Translate (MO_FF_Conv W64 W32)++-- Word comparisons masquerading as more exotic things.++  SameMutVarOp            -> \_ -> OpDest_Translate (mo_wordEq dflags)+  SameMVarOp              -> \_ -> OpDest_Translate (mo_wordEq dflags)+  SameMutableArrayOp      -> \_ -> OpDest_Translate (mo_wordEq dflags)+  SameMutableByteArrayOp  -> \_ -> OpDest_Translate (mo_wordEq dflags)+  SameMutableArrayArrayOp -> \_ -> OpDest_Translate (mo_wordEq dflags)+  SameSmallMutableArrayOp -> \_ -> OpDest_Translate (mo_wordEq dflags)+  SameTVarOp              -> \_ -> OpDest_Translate (mo_wordEq dflags)+  EqStablePtrOp           -> \_ -> OpDest_Translate (mo_wordEq dflags)+-- See Note [Comparing stable names]+  EqStableNameOp          -> \_ -> OpDest_Translate (mo_wordEq dflags)++  IntQuotRemOp -> \args -> OpDest_CallishHandledLater $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_S_QuotRem  (wordWidth dflags))+    else Right (genericIntQuotRemOp (wordWidth dflags))++  Int8QuotRemOp -> \args -> OpDest_CallishHandledLater $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_S_QuotRem W8)+    else Right (genericIntQuotRemOp W8)++  Int16QuotRemOp -> \args -> OpDest_CallishHandledLater $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_S_QuotRem W16)+    else Right (genericIntQuotRemOp W16)++  WordQuotRemOp -> \args -> OpDest_CallishHandledLater $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_U_QuotRem  (wordWidth dflags))+    else Right (genericWordQuotRemOp (wordWidth dflags))++  WordQuotRem2Op -> \_ -> OpDest_CallishHandledLater $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_U_QuotRem2 (wordWidth dflags))+    else Right (genericWordQuotRem2Op dflags)++  Word8QuotRemOp -> \args -> OpDest_CallishHandledLater $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_U_QuotRem W8)+    else Right (genericWordQuotRemOp W8)++  Word16QuotRemOp -> \args -> OpDest_CallishHandledLater $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_U_QuotRem W16)+    else Right (genericWordQuotRemOp W16)++  WordAdd2Op -> \_ -> OpDest_CallishHandledLater $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_Add2       (wordWidth dflags))+    else Right genericWordAdd2Op++  WordAddCOp -> \_ -> OpDest_CallishHandledLater $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_AddWordC   (wordWidth dflags))+    else Right genericWordAddCOp++  WordSubCOp -> \_ -> OpDest_CallishHandledLater $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_SubWordC   (wordWidth dflags))+    else Right genericWordSubCOp++  IntAddCOp -> \_ -> OpDest_CallishHandledLater $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_AddIntC    (wordWidth dflags))+    else Right genericIntAddCOp++  IntSubCOp -> \_ -> OpDest_CallishHandledLater $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_SubIntC    (wordWidth dflags))+    else Right genericIntSubCOp++  WordMul2Op -> \_ -> OpDest_CallishHandledLater $+    if ncg && (x86ish || ppc) || llvm+    then Left (MO_U_Mul2     (wordWidth dflags))+    else Right genericWordMul2Op+  FloatFabsOp -> \_ -> OpDest_CallishHandledLater $+    if (ncg && x86ish || ppc) || llvm+    then Left MO_F32_Fabs+    else Right $ genericFabsOp W32+  DoubleFabsOp -> \_ -> OpDest_CallishHandledLater $+    if (ncg && x86ish || ppc) || llvm+    then Left MO_F64_Fabs+    else Right $ genericFabsOp W64++  TagToEnumOp -> panic "emitPrimOp: handled above in cgOpApp"++-- 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 = \_ -> OpDest_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++-- | Helper datatype used to ensure completion while keeping code smaller. Could+-- be totally eliminated in optimized builds.+data OpDest+  = OpDest_Nop+  | OpDest_Narrow !(Width -> Width -> MachOp, Width)+  -- | These primops are implemented by CallishMachOps, because they sometimes+  -- turn into foreign calls depending on the backend.+  | OpDest_Callish !CallishMachOp+  | OpDest_Translate !MachOp+  | OpDest_CallishHandledLater (Either CallishMachOp GenericOp)+  | OpDest_External+  -- | 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.+  | OpDest_AllDone ([LocalReg] -- where to put the results+                    -> FCode ())++-- | Wrapper around '@dispatchPrimop@' which implements the cases represented+-- with '@OpDest@'.+--+-- 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.+emitPrimOp :: DynFlags+           -> PrimOp            -- the op+           -> [CmmExpr]         -- arguments+           -> Maybe ([LocalReg]        -- where to put the results+                      -> FCode ())++-- The rest just translate straightforwardly+emitPrimOp dflags op args = case dispatchPrimop dflags op args of+  OpDest_Nop -> Just $ \[res] -> emitAssign (CmmLocal res) arg+    where [arg] = args++  OpDest_Narrow (mop, rep) -> Just $ \[res] -> emitAssign (CmmLocal res) $+    CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]]+    where [arg] = args++  OpDest_Callish prim -> Just $ \[res] -> emitPrimCall [res] prim args++  OpDest_Translate mop -> Just $ \[res] -> do+    let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args)+    emit stmt++  OpDest_CallishHandledLater callOrNot -> Just $ \res0 -> case callOrNot of+          Left op   -> emit $ mkUnsafeCall (PrimTarget op) res0 args+          Right gen -> gen res0 args++  OpDest_AllDone f -> Just $ f++  OpDest_External -> Nothing++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/Ticky.hs view
@@ -131,8 +131,8 @@ -- Turgid imports for showTypeCategory import PrelNames import TcType-import Type import TyCon+import Predicate  import Data.Maybe import qualified Data.Char
compiler/GHC/StgToCmm/Utils.hs view
@@ -39,6 +39,11 @@         mkWordCLit,         newStringCLit, newByteStringCLit,         blankWord,++        -- * Update remembered set operations+        whenUpdRemSetEnabled,+        emitUpdRemSetPush,+        emitUpdRemSetPushThunk,   ) where  #include "HsVersions.h"@@ -576,3 +581,40 @@        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
@@ -1368,12 +1368,7 @@            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 noExtField-                                        HsBoxedOrConstraintTuple normals)-            | n == 1-               -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))+            -> returnL (HsTupleTy noExtField HsBoxedOrConstraintTuple normals)             | otherwise             -> mk_apps                (HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n))))@@ -1426,13 +1421,7 @@            VarT nm -> do { nm' <- tNameL nm                          ; mk_apps (HsTyVar noExtField 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+                         ; let prom = name_promotedness nm'                          ; mk_apps (HsTyVar noExtField prom (noLoc nm')) tys'}             ForallT tvs cxt ty@@ -1469,8 +1458,9 @@              -> do { s'  <- tconName s                    ; t1' <- cvtType t1                    ; t2' <- cvtType t2+                   ; let prom = name_promotedness s'                    ; mk_apps-                      (HsTyVar noExtField NotPromoted (noLoc s'))+                      (HsTyVar noExtField prom (noLoc s'))                       ([HsValArg t1', HsValArg t2'] ++ tys')                    } @@ -1491,8 +1481,6 @@                  -- 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 noExtField normals)@@ -1546,6 +1534,16 @@             _ -> 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)
compiler/HsVersions.h view
@@ -1,5 +1,8 @@ #pragma once +-- For GHC_STAGE+#include "ghcplatform.h"+ #if 0  IMPORTANT!  If you put extra tabs/spaces in these macro definitions,@@ -8,15 +11,6 @@ (This is cpp-dependent, of course)  #endif--/* Pull in all the platform defines for this build (foo_HOST_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 #-};             \
compiler/backpack/DriverBkp.hs view
@@ -106,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) @@ -642,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/cmm/CLabel.hs view
@@ -40,6 +40,7 @@         mkAsmTempDieLabel,          mkDirty_MUT_VAR_Label,+        mkNonmovingWriteBarrierEnabledLabel,         mkUpdInfoLabel,         mkBHUpdInfoLabel,         mkIndStaticInfoLabel,@@ -484,7 +485,9 @@                                -- See Note [Proc-point local block entry-point].  -- Constructing Cmm Labels-mkDirty_MUT_VAR_Label, mkUpdInfoLabel,+mkDirty_MUT_VAR_Label,+    mkNonmovingWriteBarrierEnabledLabel,+    mkUpdInfoLabel,     mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,     mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel,     mkMAP_DIRTY_infoLabel,@@ -494,6 +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+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
compiler/cmm/CmmInfo.hs view
@@ -74,7 +74,7 @@        ; let do_one :: UniqSupply -> [CmmDecl] -> IO (UniqSupply, [RawCmmDecl])              do_one uniqs cmm =                -- NB. strictness fixes a space leak.  DO NOT REMOVE.-               withTimingSilent (return dflags) (text "Cmm -> Raw Cmm")+               withTimingSilent dflags (text "Cmm -> Raw Cmm")                                 forceRes $                  case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of                    (b,uniqs') -> return (uniqs',b)
compiler/cmm/CmmParse.y view
@@ -375,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) }@@ -391,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@@ -475,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 ->@@ -512,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 ->@@ -575,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'@@ -585,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 }@@ -672,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 }@@ -760,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) }@@ -818,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) }@@ -1376,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)@@ -1419,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
compiler/cmm/CmmPipeline.hs view
@@ -39,7 +39,7 @@  -> CmmGroup             -- Input C-- with Procedures  -> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C-- -cmmPipeline hsc_env srtInfo prog = withTimingSilent (return dflags) (text "Cmm pipeline") forceRes $+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
compiler/cmm/Hoopl/Dataflow.hs view
@@ -6,8 +6,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fprof-auto-top #-}- -- -- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones, -- and Norman Ramsey@@ -108,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 =@@ -169,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/coreSyn/CorePrep.hs view
@@ -178,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'@@ -206,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)
− compiler/deSugar/Check.hs 
@@ -1,1407 +0,0 @@-{--Author: George Karachalias <george.karachalias@cs.kuleuven.be>--Pattern Matching Coverage Checking.--}--{-# LANGUAGE CPP            #-}-{-# LANGUAGE GADTs          #-}-{-# LANGUAGE DataKinds      #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TupleSections  #-}-{-# LANGUAGE ViewPatterns   #-}-{-# LANGUAGE MultiWayIf     #-}-{-# LANGUAGE LambdaCase     #-}--module Check (-        -- 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 PmTypes-import PmOracle-import PmPpr-import BasicTypes (Origin, isGenerated)-import CoreSyn (CoreExpr, Expr(Var))-import CoreUtils (exprType)-import FastString (unpackFS)-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 BasicTypes (Boxity(..))-import Var (EvVar)-import Coercion-import TcEvidence-import {-# SOURCE #-} DsExpr (dsExpr, dsLExpr, dsSyntaxExpr)-import MatchLit (dsLit, dsOverLit)-import IOEnv-import DsMonad-import Bag-import TyCoRep-import Type-import DsUtils       (isTrueLHsExpr)-import Maybes        (isJust, expectJust)-import qualified GHC.LanguageExtensions as LangExt--import Data.List     (find)-import Control.Monad (forM, when, forM_)-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Maybe-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-%*                                                                      *-%************************************************************************--}--data PmPat where-  -- | For the arguments' meaning see 'HsPat.ConPatOut'.-  PmCon  :: { pm_con_con     :: PmAltCon-            , pm_con_arg_tys :: [Type]-            , pm_con_tvs     :: [TyVar]-            , pm_con_args    :: [PmPat] } -> PmPat--  PmVar  :: { pm_var_id   :: Id } -> PmPat--  PmGrd  :: { pm_grd_pv   :: PatVec -- ^ Always has 'patVecArity' 1.-            , pm_grd_expr :: CoreExpr } -> PmPat-     -- (PmGrd pat expr) matches expr against pat, binding the variables in pat---- | Should not be user-facing.-instance Outputable PmPat where-  ppr (PmCon alt _arg_tys _con_tvs con_args)-    = cparen (notNull con_args) (hsep [ppr alt, hsep (map ppr con_args)])-  ppr (PmVar vid) = ppr vid-  ppr (PmGrd pv ge) = hsep (map ppr pv) <+> text "<-" <+> ppr ge---- 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---- | Pattern Vectors. The *arity* of a PatVec [p1,..,pn] is--- the number of p1..pn that are not Guards. See 'patternArity'.-type PatVec = [PmPat]-type ValVec = [Id] -- ^ Value Vector Abstractions---- | 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    :: UncoveredCandidates-    , 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)-    ]---- | 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 [Id] [Delta]-                         | TypeOfUncovered Type--instance Outputable UncoveredCandidates where-  ppr (UncoveredPatterns vva deltas) = text "UnPat" <+> ppr vva $$ ppr deltas-  ppr (TypeOfUncovered ty)   = text "UnTy" <+> ppr 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-  tracePm "checkSingle" (vcat [ppr ctxt, ppr var, ppr p])-  res <- checkSingle' locn var p-  dsPmWarn dflags ctxt res---- | Check a single pattern binding (let)-checkSingle' :: SrcSpan -> Id -> Pat GhcTc -> DsM PmResult-checkSingle' locn var p = do-  fam_insts <- dsGetFamInstEnvs-  clause    <- translatePat fam_insts p-  missing   <- getPmDelta-  tracePm "checkSingle': missing" (ppr missing)-  PartialResult cs us ds pc <- pmcheckI clause [] [var] 1 missing-  dflags <- getDynFlags-  us' <- getNFirstUncovered [var] (maxUncoveredPatterns dflags + 1) us-  let uc = UncoveredPatterns [var] us'-  return $ case (cs,ds) of-    (Covered,  _    )         -> PmResult [] uc [] pc -- useful-    (NotCovered, NotDiverged) -> PmResult m  uc [] pc -- redundant-    (NotCovered, Diverged )   -> PmResult [] uc m  pc -- 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 <- case matches of-    -- Check EmptyCase separately-    -- See Note [Checking EmptyCase Expressions] in PmOracle-    [] | [var] <- vars -> checkEmptyCase' var-    _normal_match      -> checkMatches' vars matches-  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)] -> DsM PmResult-checkMatches' vars matches-  | null matches = panic "checkMatches': EmptyCase"-  | otherwise = do-      missing    <- getPmDelta-      tracePm "checkMatches': missing" (ppr missing)-      (rs,us,ds,pc) <- go matches [missing]-      dflags <- getDynFlags-      us' <- getNFirstUncovered vars (maxUncoveredPatterns dflags + 1) us-      let up = UncoveredPatterns vars us'-      return $ PmResult {-                   pmresultRedundant    = map hsLMatchToLPats rs-                 , pmresultUncovered    = up-                 , 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 m-      let limit           = maxPmCheckModels dflags-          n_siblings      = length missing-          throttled_check delta =-            snd <$> throttle limit (pmcheckI clause guards vars) 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'"---- | Check an empty case expression. Since there are no clauses to process, we---   only compute the uncovered set. See Note [Checking EmptyCase Expressions]---   in "PmOracle" for details.-checkEmptyCase' :: Id -> DsM PmResult-checkEmptyCase' x = do-  delta         <- getPmDelta-  us <- inhabitants delta (idType x) >>= \case-    -- Inhabitation checking failed / the type is trivially inhabited-    Left ty            -> pure (TypeOfUncovered ty)-    -- A list of oracle states for the different satisfiable constructors is-    -- available. Turn this into a value set abstraction.-    Right (va, deltas) -> pure (UncoveredPatterns [va] deltas)-  pure (PmResult [] us [] Precise)--getNFirstUncovered :: [Id] -> Int -> [Delta] -> DsM [Delta]-getNFirstUncovered _    0 _              = pure []-getNFirstUncovered _    _ []             = pure []-getNFirstUncovered vars n (delta:deltas) = do-  front <- provideEvidenceForEquation vars n delta-  back <- getNFirstUncovered vars (n - length front) deltas-  pure (front ++ back)--{--%************************************************************************-%*                                                                      *-              Transform source syntax to *our* syntax-%*                                                                      *-%************************************************************************--}---- -------------------------------------------------------------------------- * Utilities--nullaryConPattern :: ConLike -> PmPat--- Nullary data constructor and nullary type constructor-nullaryConPattern con =-  PmCon { pm_con_con = (PmAltConLike con), pm_con_arg_tys = []-        , pm_con_tvs = [], pm_con_args = [] }-{-# INLINE nullaryConPattern #-}--truePattern :: PmPat-truePattern = nullaryConPattern (RealDataCon trueDataCon)-{-# INLINE truePattern #-}--vanillaConPattern :: ConLike -> [Type] -> PatVec -> PmPat--- ADT constructor pattern => no existentials, no local constraints-vanillaConPattern con arg_tys args =-  PmCon { pm_con_con = PmAltConLike con, pm_con_arg_tys = arg_tys-        , pm_con_tvs = [], pm_con_args = args }-{-# INLINE vanillaConPattern #-}---- | Create an empty list pattern of a given type-nilPattern :: Type -> PmPat-nilPattern ty =-  PmCon { pm_con_con = PmAltConLike (RealDataCon nilDataCon)-        , pm_con_arg_tys = [ty], pm_con_tvs = [], pm_con_args = [] }-{-# INLINE nilPattern #-}--mkListPatVec :: Type -> PatVec -> PatVec -> PatVec-mkListPatVec ty xs ys = [PmCon { pm_con_con = PmAltConLike (RealDataCon consDataCon)-                               , pm_con_arg_tys = [ty]-                               , pm_con_tvs = []-                               , pm_con_args = xs++ys }]-{-# INLINE mkListPatVec #-}---- | Create a literal pattern-mkPmLitPattern :: PmLit -> PatVec-mkPmLitPattern lit@(PmLit _ val)-  -- We translate String literals to list literals for better overlap reasoning.-  -- It's a little unfortunate we do this here rather than in-  -- 'PmOracle.trySolve' and 'PmOracle.addRefutableAltCon', but it's so much-  -- simpler here.-  -- See Note [Representation of Strings in TmState] in PmOracle-  | PmLitString s <- val-  , let mk_char_lit c = mkPmLitPattern (PmLit charTy (PmLitChar c))-  = foldr (\c p -> mkListPatVec charTy (mk_char_lit c) p)-          [nilPattern charTy]-          (unpackFS s)-  | otherwise-  = [PmCon { pm_con_con = PmAltLit lit-           , pm_con_arg_tys = []-           , pm_con_tvs = []-           , pm_con_args = [] }]-{-# INLINE mkPmLitPattern #-}---- -------------------------------------------------------------------------- * Transform (Pat Id) into [PmPat]--- The arity of the [PmPat] is always 1, but it may be a combination--- of a vanilla pattern and a guard pattern.--- Example: view pattern  (f y -> Just x)---          becomes       [PmVar z, PmGrd [PmPat (Just x), f y]]---          where z is fresh--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)--  -- (x@pat)   ===>   x (pat <- x)-  AsPat _ (dL->L _ x) p -> do-    pat <- translatePat fam_insts (unLoc p)-    pure [PmVar x, PmGrd pat (Var x)]--  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-        g <- mkGuard ps (mkHsWrap wrapper (unLoc xe))-        pure [xp,g]--  -- (n + k)  ===>   x (True <- x >= k) (n <- x-k)-  NPlusKPat pat_ty (dL->L _ n) k1 k2 ge minus -> do-    (xp, xe) <- mkPmId2Forms pat_ty-    let ke1 = HsOverLit noExtField (unLoc k1)-        ke2 = HsOverLit noExtField k2-    g1 <- mkGuardSyntaxExpr [truePattern] ge    [unLoc xe, ke1]-    g2 <- mkGuardSyntaxExpr [PmVar n]     minus [ke2]-    return [xp, g1, g2]--  -- (fun -> pat)   ===>   x (pat <- fun x)-  ViewPat arg_ty lexpr lpat -> do-    ps <- translatePat fam_insts (unLoc lpat)-    (xp,xe) <- mkPmId2Forms arg_ty-    g <- mkGuard ps (HsApp noExtField lexpr xe)-    return [xp, g]--  -- list-  ListPat (ListPatTc ty Nothing) ps -> do-    pv <- translatePatVec fam_insts (map unLoc ps)-    return (foldr (mkListPatVec ty) [nilPattern ty] pv)--  -- overloaded list-  ListPat (ListPatTc elem_ty (Just (pat_ty, to_list))) lpats -> do-    dflags <- getDynFlags-    case splitListTyConApp_maybe pat_ty of-      Just e_ty-        | not (xopt LangExt.RebindableSyntax dflags)-        -- Just translate it as a regular ListPat-        -> translatePat fam_insts (ListPat (ListPatTc e_ty Nothing) lpats)-      _ -> do-        ps       <- translatePatVec fam_insts (map unLoc lpats)-        (xp, xe) <- mkPmId2Forms pat_ty-        let pats = foldr (mkListPatVec elem_ty) [nilPattern elem_ty] ps-        g <- mkGuardSyntaxExpr pats to_list [unLoc xe]-        return [xp,g]--    -- (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.-    ---    -- Here we construct CanFailPmPat directly, rather can construct a view-    -- pattern and do further translation as an optimization, for the reason,-    -- see Note [Countering exponential blowup].--  ConPatOut { pat_con     = (dL->L _ con)-            , pat_arg_tys = arg_tys-            , pat_tvs     = ex_tvs-            , pat_args    = ps } -> do-    args <- translateConPatVec fam_insts arg_tys ex_tvs con ps-    return [PmCon { pm_con_con     = PmAltConLike con-                  , pm_con_arg_tys = arg_tys-                  , pm_con_tvs     = ex_tvs-                  , pm_con_args    = args }]--  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-    return (mkPmLitPattern lit')--  LitPat _ lit -> do-    core_expr <- dsLit (convertLit lit)-    let lit = expectJust "failed to detect Lit" (coreExprAsPmLit core_expr)-    return (mkPmLitPattern 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"---- | 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 (Var 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-      -- 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"--        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 =-  concat <$> mapM (translateGuard fam_insts) guards---- | 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 nec        -> noExtCon nec---- | 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-  g <- mkGuard ps (unLoc e)-  return [g]---- | 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 = (:[]) <$> mkGuard [truePattern] (unLoc e)--{- 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---- | 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 -> Type-pmPatType (PmCon { pm_con_con = con, pm_con_arg_tys = tys })-  = pmAltConType con tys-pmPatType (PmVar  { pm_var_id  = x }) = idType x-pmPatType (PmGrd  { pm_grd_pv  = pv })-  = ASSERT(patVecArity pv == 1) (pmPatType p)-  where Just p = find ((==1) . patternArity) pv--{--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 PmOracle.-* Efficient handling of literal splitting, large enumerations and accurate-  redundancy warnings for `COMPLETE` groups through the oracle.--}---- ------------------------------------------------------------------------------- * More smart constructors and fresh variable generation---- | Create a guard pattern-mkGuard :: PatVec -> HsExpr GhcTc -> DsM PmPat-mkGuard pv e = PmGrd pv <$> dsExpr e--mkGuardSyntaxExpr :: PatVec -> SyntaxExpr GhcTc -> [HsExpr GhcTc] -> DsM PmPat-mkGuardSyntaxExpr pv f args = do-  core_args <- traverse dsExpr args-  PmGrd pv <$> dsSyntaxExpr f core_args---- | Generate a variable pattern of a given type-mkPmVar :: Type -> DsM PmPat-mkPmVar ty = PmVar <$> mkPmId ty---- | Generate many variable patterns, given a list of types-mkPmVars :: [Type] -> DsM PatVec-mkPmVars tys = mapM mkPmVar tys---- | Generate a fresh term variable of a given and return it in two forms:--- * A variable pattern--- * A variable expression-mkPmId2Forms :: Type -> DsM (PmPat, LHsExpr GhcTc)-mkPmId2Forms ty = do-  x <- mkPmId ty-  return (PmVar x, noLoc (HsVar noExtField (noLoc x)))--{--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.--}--{--%************************************************************************-%*                                                                      *-                             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 :: PmPat -> PmArity-patternArity (PmGrd {}) = 0-patternArity _other_pat = 1--{--%************************************************************************-%*                                                                      *-            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'.-pmcheckI :: PatVec -> [PatVec] -> ValVec -> Int -> Delta -> DsM PartialResult-pmcheckI ps guards vva n delta = do-  tracePm "pmCheck {" $ vcat [ ppr n <> colon-                           , hang (text "patterns:") 2 (ppr ps)-                           , hang (text "guards:") 2 (ppr guards)-                           , ppr vva-                           , ppr delta ]-  res <- pmcheck ps guards vva n delta-  tracePm "}:" (ppr res) -- braces are easier to match by tooling-  return res-{-# INLINE pmcheckI #-}---- | Check the list of mutually exclusive guards-pmcheckGuards :: [PatVec] -> 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 (pmcheckI 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-  :: PatVec   -- ^ Patterns of the clause-  -> [PatVec] -- ^ (Possibly multiple) guards of the clause-  -> ValVec   -- ^ The value vector abstraction to match against-  -> 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---- Guard-pmcheck (p@PmGrd { pm_grd_pv = pv, pm_grd_expr = e } : ps) guards vva n delta = do-  tracePm "PmGrd: pmPatType" (vcat [ppr p, ppr (pmPatType p)])-  x <- mkPmId (exprType e)-  delta' <- expectJust "x is fresh" <$> addVarCoreCt delta x e-  pmcheckI (pv ++ ps) guards (x : vva) n delta'---- Var: Add x :-> y to the oracle and recurse-pmcheck (PmVar x : ps) guards (y : vva) n delta = do-  delta' <- expectJust "x is fresh" <$> addTmCt delta (TmVarVar x y)-  pmcheckI ps guards vva n delta'---- ConVar-pmcheck (p@PmCon{ pm_con_con = con, pm_con_args = args-                , pm_con_arg_tys = arg_tys, pm_con_tvs = ex_tvs } : ps)-        guards (x : vva) n delta = do-  -- E.g   f (K p q) = <rhs>-  --       <next equation>-  -- Split the value vector into two value vectors:-  --    * one for <rhs>, binding x to (K p q)-  --    * one for <next equation>, recording that x is /not/ (K _ _)--  -- Stuff for <rhs>-  pr_pos <- refineToAltCon delta x con arg_tys ex_tvs >>= \case-    Nothing -> pure mempty-    Just (delta', arg_vas) ->-      pmcheckI (args ++ ps) guards (arg_vas ++ vva) n delta'--  -- Stuff for <next equation>-  -- The var is forced regardless of whether @con@ was satisfiable-  let pr_pos' = forceIfCanDiverge delta x pr_pos-  pr_neg <- addRefutableAltCon delta x con >>= \case-    Nothing     -> pure mempty-    Just delta' -> pure (usimple delta')--  tracePm "ConVar" (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--pmcheck [] _ (_:_) _ _ = panic "pmcheck: nil-cons"-pmcheck (_:_) _ [] _ _ = panic "pmcheck: cons-nil"---- ------------------------------------------------------------------------------- * 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---- ------------------------------------------------------------------------------- * 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--- Morally, this computes an approximation of the Covered set for p1--- (which pmcheck currently discards). TODO: Re-use pmcheck instead of calling--- out to awkard addVarPatVecCt.-addPatTmCs ps xs k = do-  fam_insts <- dsGetFamInstEnvs-  pv <- concat <$> translatePatVec fam_insts ps-  locallyExtendPmDelta (\delta -> addVarPatVecCt delta xs pv) k---- | Add a constraint equating a variable to a 'PatVec'. Picks out the single--- 'PmPat' of arity 1 and equates x to it. Returns the original Delta if that--- fails. Otherwise it returns Nothing when the resulting Delta would be--- unsatisfiable, or @Just delta'@ when the extended @delta'@ is still possibly--- satisfiable.-addVarPatVecCt :: Delta -> [Id] -> PatVec -> DsM (Maybe Delta)--- This is just a simple version of pmcheck to compute the Covered Delta--- (which pmcheck doesn't even attempt to keep).--- Also PmGrd, although having pattern arity 0, really stores important info.--- For example, as-patterns desugar to a plain variable match and an associated--- PmGrd for the RHS of the @. We don't currently look into that PmGrd and I'm--- not willing to duplicate any more of pmcheck.-addVarPatVecCt delta (x:xs) (pat:pv)-  | patternArity pat == 1 -- PmVar or PmCon-  = runMaybeT $ do-      delta' <- MaybeT (addVarPatCt delta x pat)-      MaybeT (addVarPatVecCt delta' xs pv)-  | otherwise -- PmGrd or PmFake-  = addVarPatVecCt delta (x:xs) pv-addVarPatVecCt delta []     pv = ASSERT( patVecArity pv == 0 ) pure (Just delta)-addVarPatVecCt _     (_:_)  [] = panic "More match vars than patterns"---- | Convert a pattern to a 'PmTypes' (will be either 'Nothing' if the pattern is--- a guard pattern, or 'Just' an expression in all other cases) by dropping the--- guards-addVarPatCt :: Delta -> Id -> PmPat -> DsM (Maybe Delta)-addVarPatCt delta x (PmVar { pm_var_id  = y }) = addTmCt delta (TmVarVar x y)-addVarPatCt delta x (PmCon { pm_con_con = con, pm_con_args = args }) = runMaybeT $ do-  arg_ids <- traverse (lift . mkPmId . pmPatType) args-  delta' <- foldlM (\delta (y, arg) -> MaybeT (addVarPatCt delta y arg)) delta (zip arg_ids args)-  MaybeT (addTmCt delta' (TmVarCon x con arg_ids))-addVarPatCt delta _ _pat = ASSERT( patternArity _pat == 0 ) pure (Just 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 -> PmResult -> DsM ()-dsPmWarn dflags ctx@(DsMatchContext kind loc) 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 && (case uncovered of-                                  TypeOfUncovered   _     -> True-                                  UncoveredPatterns _ unc -> notNull unc)-          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 $-        case uncovered of-          TypeOfUncovered ty    -> warnEmptyCase ty-          UncoveredPatterns vars unc -> pprEqns vars unc-  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)--    -- 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 = pprContext False ctx (text "are non-exhaustive") $ \_ ->-      hang (text "Patterns not matched:") 4 (underscore <+> dcolon <+> ppr ty)--    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/deSugar/Coverage.hs view
@@ -1071,7 +1071,7 @@ --   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).
compiler/deSugar/Desugar.hs view
@@ -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
compiler/deSugar/DsArrows.hs view
@@ -327,7 +327,7 @@     fail_expr <- mkFailExpr ProcExpr env_stk_ty     var <- selectSimpleMatchVarL pat     match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr-    let pat_ty = hsLPatType pat+    let pat_ty = hsPatType pat     let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty                     (Lam var match_code)                     core_cmd@@ -868,7 +868,7 @@ -- but that's likely to be defined in terms of first.  dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do-    let pat_ty = hsLPatType pat+    let pat_ty = hsPatType pat     (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd     let pat_vars = mkVarSet (collectPatBinders pat)     let
compiler/deSugar/DsBinds.hs view
@@ -29,7 +29,7 @@ import DsMonad import DsGRHSs import DsUtils-import Check ( needToRunPmCheck, addTyCsDs, checkGuardMatches )+import GHC.HsToCore.PmCheck ( needToRunPmCheck, addTyCsDs, checkGuardMatches )  import GHC.Hs           -- lots of things import CoreSyn          -- lots of things@@ -41,6 +41,7 @@ import CoreUnfold import CoreFVs import Digraph+import Predicate  import PrelNames import TyCon
+ 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/DsExpr.hs view
@@ -25,7 +25,7 @@ import DsUtils import DsArrows import DsMonad-import Check ( checkGuardMatches )+import GHC.HsToCore.PmCheck ( checkGuardMatches ) import Name import NameEnv import FamInstEnv( topNormaliseType )@@ -393,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)@@ -929,7 +930,7 @@                  (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))                do_arg (XApplicativeArg nec) = noExtCon nec -               arg_tys = map hsLPatType pats+               arg_tys = map hsPatType pats             ; rhss' <- sequence rhss
compiler/deSugar/DsGRHSs.hs view
@@ -25,7 +25,7 @@  import BasicTypes (Origin(FromSource)) import DynFlags-import Check (needToRunPmCheck, addTyCsDs, addPatTmCs, addScrutTmCs)+import GHC.HsToCore.PmCheck (needToRunPmCheck, addTyCsDs, addPatTmCs, addScrutTmCs) import DsMonad import DsUtils import Type   ( Type )
compiler/deSugar/DsListComp.hs view
@@ -279,7 +279,7 @@     let u3_ty@u1_ty = exprType core_list1       -- two names, same thing          -- u1_ty is a [alpha] type, and u2_ty = alpha-    let u2_ty = hsLPatType pat+    let u2_ty = hsPatType pat      let res_ty = exprType core_list2         h_ty   = u1_ty `mkVisFunTy` res_ty@@ -373,7 +373,7 @@            -> DsM CoreExpr dfBindComp c_id n_id (pat, core_list1) quals = do     -- find the required type-    let x_ty   = hsLPatType pat+    let x_ty   = hsPatType pat     let b_ty   = idType n_id      -- create some new local id's
compiler/deSugar/DsMeta.hs view
@@ -1394,7 +1394,7 @@ repE (HsSpliceE _ splice)  = repSplice splice repE (HsStatic _ e)        = repLE e >>= rep2 staticEName . (:[]) . unC repE (HsUnboundVar _ uv)   = do-                               occ   <- occNameLit (unboundVarOcc uv)+                               occ   <- occNameLit uv                                sname <- repNameS occ                                repUnboundVar sname
compiler/deSugar/DsMonad.hs view
@@ -70,7 +70,7 @@ import DataCon import ConLike import TyCon-import PmTypes+import GHC.HsToCore.PmCheck.Types import Id import Module import Outputable
compiler/deSugar/DsUsage.hs view
@@ -319,10 +319,10 @@                 -- 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,@@ -672,7 +672,7 @@   = return (v, [(v, val_expr)])    | is_flat_prod_lpat pat'           -- Special case (B)-  = do { let pat_ty = hsLPatType pat'+  = do { let pat_ty = hsPatType pat'        ; val_var <- newSysLocalDsNoLP pat_ty         ; let mk_bind tick bndr_var@@ -756,12 +756,9 @@ 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+mkVanillaTuplePat pats box = TuplePat (map hsPatType pats) pats box  -- The Big equivalents for the source tuple expressions mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
compiler/deSugar/Match.hs view
@@ -25,7 +25,7 @@ import TcHsSyn import TcEvidence import TcRnMonad-import Check+import GHC.HsToCore.PmCheck import CoreSyn import Literal import CoreUtils
− compiler/deSugar/PmOracle.hs 
@@ -1,1703 +0,0 @@-{--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', 'refineToAltCon' and 'addRefutableAltCon' for adding--- facts to the oracle, and 'provideEvidenceForEquation' to turn a 'Delta' into--- a concrete evidence for an equation.-module PmOracle (--        DsM, tracePm, mkPmId,-        Delta, initDelta, canDiverge, lookupRefuts, lookupSolution,--        TmCt(..),-        inhabitants,-        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-        refineToAltCon,     -- Add a positive refinement x ~ K _ _-        tmOracle,           -- Add multiple positive term equalities-        provideEvidenceForEquation,-    ) where--#include "HsVersions.h"--import GhcPrelude--import PmTypes--import DynFlags-import Outputable-import ErrUtils-import Util-import Bag-import UniqDSet-import Unique-import Id-import VarEnv-import UniqDFM-import Var           (EvVar)-import Name-import CoreSyn-import CoreFVs ( exprFreeVars )-import CoreOpt (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)-import Data.List     (find)-import qualified Data.List.NonEmpty as NonEmpty-import qualified Data.Semigroup as Semigroup---- 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--initIM :: Type -> DsM (Maybe PossibleMatches)-initIM ty = case splitTyConApp_maybe ty of-  Nothing -> pure Nothing-  Just (tc, tc_args) -> do-    -- Look into the representation type of a data family instance, too.-    env <- dsGetFamInstEnvs-    let (tc', _tc_args', _co) = tcLookupDataFamInst env tc tc_args-    let mb_rdcs = map RealDataCon <$> tyConDataCons_maybe tc'-    let rdcs = maybeToList mb_rdcs-    -- NB: tc, because COMPLETE sets are associated with the parent data family-    -- TyCon-    pragmas <- dsGetCompleteMatches tc-    let fams = mapM dsLookupConLike . completeMatchConLikes-    pscs <- mapM fams pragmas-    pure (PM tc . fmap mkUniqDSet <$> NonEmpty.nonEmpty (rdcs ++ pscs))--markMatched :: ConLike -> PossibleMatches -> PossibleMatches-markMatched con (PM tc ms) = PM tc (fmap (`delOneFromUniqDSet` con) ms)-markMatched _   NoPM = NoPM---- | Satisfiability decisions as a data type. The @proof@ can carry a witness--- for satisfiability and might even be instantiated to 'Data.Void.Void' to--- degenerate into a semi-decision predicate.-data Satisfiability proof-  = Unsatisfiable-  | PossiblySatisfiable-  | Satisfiable !proof--maybeSatisfiable :: Maybe a -> Satisfiability a-maybeSatisfiable (Just a) = Satisfiable a-maybeSatisfiable Nothing  = Unsatisfiable---- | Tries to return one of the possible 'ConLike's from one of the COMPLETE--- sets. If the 'PossibleMatches' was inhabited before (cf. 'ensureInhabited')--- this 'ConLike' is evidence for that assurance.-getUnmatchedConstructor :: PossibleMatches -> Satisfiability ConLike-getUnmatchedConstructor NoPM = PossiblySatisfiable-getUnmatchedConstructor (PM _tc ms)-  = maybeSatisfiable $ NonEmpty.head <$> traverse pick_one_conlike ms-  where-    pick_one_conlike cs = case uniqDSetToList cs of-      [] -> Nothing-      (cl:_) -> Just cl-------------------------------------------------------- * Instantiating constructors, types and evidence---- | Instantiate a 'ConLike' given its universal type arguments. Instantiates--- existential and term binders with fresh variables of appropriate type.--- Also returns instantiated evidence variables from the match and the types of--- strict constructor fields.-mkOneConFull :: [Type] -> ConLike -> DsM ([Id], Bag TyCt, [Type], [TyVar])---  * '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 in #11336, #17112, the univ_ts include those variables---         from the view pattern, so tys will have to come from the type checker.---         They can't easily be recovered from the result type.------ 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]---          [e1,..,en]-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-  (subst, ex_tvs') <- 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_banged = map isBanged $ conLikeImplBangs con-      strict_arg_tys = filterByList arg_is_banged field_tys'-  return (vars, listToBag ty_cs, strict_arg_tys, ex_tvs')--equateTyVars :: [TyVar] -> [TyVar] -> Bag TyCt-equateTyVars ex_tvs1 ex_tvs2-  = ASSERT(ex_tvs1 `equalLength` ex_tvs2)-    listToBag $ catMaybes $ zipWith mb_to_evvar ex_tvs1 ex_tvs2-  where-    mb_to_evvar tv1 tv2-      | tv1 == tv2 = Nothing-      | otherwise  = Just (to_evvar tv1 tv2)-    to_evvar tv1 tv2 = TyCt $ mkPrimEqPred (mkTyVarTy tv1) (mkTyVarTy tv2)------------------------------ * 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-  -- ^ '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, so that we don't have to-  -- reconstruct it in inhabitationCandidates.build_newtype.---- | 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--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 EmptyCase] 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 for EmptyCase].-       (_, 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, DataCon)])-    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):)-                           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 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 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 and the type we unwrap.-  (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,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, 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-       ; ((_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 -> do-  tracePm "tyIsSatisfiable" (ppr new_ty_cs)-  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 vanilla-    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 vanilla-    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 -> tmOracle delta new_tm_cs---- | External interface to the term oracle.-tmOracle :: Foldable f => Delta -> f TmCt -> DsM (Maybe Delta)-tmOracle delta = runMaybeT . foldlM go delta-  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-  mb_pm <- initIM ty'-  -- tracePm "initPossibleMatches" (ppr vi $$ ppr ty' $$ ppr res $$ ppr mb_pm)-  case mb_pm of-    Nothing -> pure vi-    Just pm -> pure vi{ vi_ty = ty', vi_cache = pm }-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)----------------------------------------------------- * Exported utility functions querying 'Delta'---- | Check whether a constraint (x ~ BOT) can succeed,--- given the resulting state of the term oracle.-canDiverge :: Delta -> Id -> Bool-canDiverge MkDelta{ delta_tm_st = ts } x-  -- If the variable seems not evaluated, there is a possibility for-  -- constraint x ~ BOT to be satisfiable. That's the case when we haven't found-  -- a solution (i.e. some equivalent literal or constructor) for it yet.-  -- Even if we don't have a solution yet, it might be involved in a negative-  -- constraint, in which case we must already have evaluated it earlier.-  | VI _ [] [] _ <- lookupVarInfo ts x-  = True-  -- Variable x is already in WHNF or we know some refutable shape, so the-  -- constraint is non-satisfiable-  | otherwise = False--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]--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)---- | 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---- | 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 } 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') }--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 were 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--ensureInhabited :: Delta -> VarInfo -> DsM (Maybe VarInfo)-   -- Returns (Just vi) guarantees that 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 tc ms) = runMaybeT (PM tc <$> 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, _ex_tyvars) <- mkOneConFull arg_tys con-          -- 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 }-  = runMaybeT (set_tm_cs_env delta <$> traverseSDIE go env)-  where-    set_tm_cs_env delta env = delta{ delta_tm_st = TmSt env }-    go vi = MaybeT (ensureInhabited delta vi)---- | @refineToAltCon delta x con arg_tys ex_tyvars@ instantiates @con@ at--- @arg_tys@ with fresh variables (equating existentials to @ex_tyvars@).--- It adds a new term equality equating @x@ is to the resulting 'PmAltCon' app--- and new type equalities arising from GADT matches.--- If successful, returns the new @delta@ and the fresh term variables, or--- @Nothing@ otherwise.-refineToAltCon :: Delta -> Id -> PmAltCon -> [Type] -> [TyVar] -> DsM (Maybe (Delta, [Id]))-refineToAltCon delta x l@PmAltLit{}           _arg_tys _ex_tvs1 = runMaybeT $ do-  delta' <- addVarConCt delta x l []-  pure (delta', [])-refineToAltCon delta x alt@(PmAltConLike con) arg_tys  ex_tvs1  = do-  -- The plan for ConLikes:-  -- Suppose K :: forall a b y z. (y,b) -> z -> T a b-  --   where the y,z are the existentials-  -- @refineToAltCon delta x K [ex1, ex2]@ extends delta with the-  --   positive information x :-> K y' z' p q, for some fresh y', z', p, q.-  --   This is done by mkOneConFull.-  --   We return the fresh [p,q] args, and bind the existentials [y',z'] to-  --   [ex1, ex2].-  -- Return Nothing if such a match is contradictory with delta.--  (arg_vars, theta_ty_cs, strict_arg_tys, ex_tvs2) <- mkOneConFull arg_tys con--  -- 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].-  let ex_ty_cs = equateTyVars ex_tvs1 ex_tvs2--  let new_ty_cs = theta_ty_cs `unionBags` ex_ty_cs-  let new_tm_cs = unitBag (TmVarCon x alt arg_vars)--  -- Now check satifiability-  mb_delta <- pmIsSatisfiable delta new_tm_cs new_ty_cs strict_arg_tys-  tracePm "refineToAltCon" (vcat [ ppr x-                                 , ppr new_tm_cs-                                 , ppr new_ty_cs-                                 , ppr strict_arg_tys-                                 , ppr delta-                                 , ppr mb_delta ])-  case mb_delta of-    Nothing     -> pure Nothing-    Just delta' -> pure (Just (delta', arg_vars))--{--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!--}------------------------------------------- * 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 } 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) })-      (_, Nothing) -> pure (delta{ delta_tm_st = TmSt (setIndirectSDIE env y x) })-      -- 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 }-        -- 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 } 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))}--------------------------------------------- * 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, _ex_tyvars) <- 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-    -- All these types are trivially inhabited-    trivially_inhabited = [ charTyCon, doubleTyCon, floatTyCon-                          , intTyCon, wordTyCon, word8TyCon ]--    build_newtype :: (Type, DataCon) -> Id -> DsM (Id, TmCt)-    build_newtype (ty, dc) 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)] -> 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)]-                  -> DsM (Either Type (TyCon, Id, [InhabitationCandidate]))-    alts_to_check src_ty core_ty dcs = case splitTyConApp_maybe core_ty of-      Just (tc, _)-        |  tc `elem` trivially_inhabited-        -> 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)--inhabitants :: Delta -> Type -> DsM (Either Type (Id, [Delta]))-inhabitants delta ty = inhabitationCandidates delta ty >>= \case-  Left ty' -> pure (Left ty')-  Right (_, va, candidates) -> do-    deltas <- flip mapMaybeM candidates $-        \InhabitationCandidate{ ic_tm_cs = tm_cs-                              , ic_ty_cs = ty_cs-                              , ic_strict_arg_tys = strict_arg_tys } -> do-      pmIsSatisfiable delta tm_cs ty_cs strict_arg_tys-    pure (Right (va, deltas))--------------------------------- * 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 for EmptyCase]-   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) -> 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---- | @provideEvidenceForEquation 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.-provideEvidenceForEquation :: [Id] -> Int -> Delta -> DsM [Delta]-provideEvidenceForEquation = go init_ts-  where-    -- Choosing 1 here will not be enough for RedBlack, but any other bound-    -- might potentially lead to combinatorial explosion, so we are extremely-    -- cautious and pick 2 here.-    init_ts                  = setRecTcMaxBound 2 initRecTc-    go _      _      0 _     = pure []-    go _      []     _ delta = pure [delta]-    go rec_ts (x:xs) n delta = do-      VI ty pos neg pm <- 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 rec_ts (arg_vas ++ xs) n delta-        []-          -- First the simple case where we don't need to query the oracles-          | isVanillaDataType ty-              -- So no type info unleashed in pattern match-          , null neg-              -- No term-level info either-          || notNull [ l | PmAltLit l <- neg ]-              -- ... or there are literals involved, in which case we don't want-              -- to split on possible constructors-          -> go rec_ts xs n delta-        [] -> do-          -- We have to pick one of the available constructors and try it-          -- It's important that each of the ConLikeSets in pm is still inhabited,-          -- so that it doesn't matter from which we pick.-          -- I think we implicitly uphold that invariant, but not too sure-          case getUnmatchedConstructor pm of-            Unsatisfiable -> pure []-            -- No COMPLETE sets available, so we can assume it's inhabited-            PossiblySatisfiable -> go rec_ts xs n delta-            Satisfiable cl-              | Just rec_ts' <- checkRecTc rec_ts (fst (splitTyConApp ty))-              -> split_at_con rec_ts' delta n x xs cl-              | otherwise-              -- We ran out of fuel; just conservatively assume that this is-              -- inhabited.-              -> go rec_ts xs n delta--    -- | @split_at_con _ delta _ x _ con@ splits the given delta into two-    -- models: One where we assume x is con and one where we assume it can't be-    -- con. Really similar to the ConVar case in Check, only that we don't-    -- really have a pattern driving the split.-    split_at_con-      :: RecTcChecker -- ^ Detects when we split the same TyCon too often-      -> Delta        -- ^ The model we like to refine to the split-      -> Int          -- ^ The number of equations still to produce-      -> Id -> [Id]   -- ^ Head and tail of the value abstractions-      -> ConLike      -- ^ The ConLike over which to split-      -> DsM [Delta]-    split_at_con rec_ts delta n x xs cl = do-      -- This will be really similar to the ConVar case-      let (_,ex_tvs,_,_,_,_,_) = conLikeFullSig cl-          -- we might need to freshen ex_tvs. Not sure-      -- We may need to reduce type famlies/synonyms in x's type first-      res <- pmTopNormaliseType (delta_ty_st delta) (idType x)-      let res_ty = normalisedSourceType res-      env <- dsGetFamInstEnvs-      case guessConLikeUnivTyArgsFromResTy env res_ty cl of-        Nothing      -> pure [delta] -- We can't split this one, so assume it's inhabited-        Just arg_tys -> do-          ev_pos <- refineToAltCon delta x (PmAltConLike cl) arg_tys ex_tvs >>= \case-            Nothing                -> pure []-            Just (delta', arg_vas) ->-              go rec_ts (arg_vas ++ xs) n delta'--          -- Only n' more equations to go...-          let n' = n - length ev_pos-          ev_neg <- addRefutableAltCon delta x (PmAltConLike cl) >>= \case-            Nothing                          -> pure []-            Just delta'                      -> go rec_ts (x:xs) n' delta'--          -- Actually there was no need to split if we see that both branches-          -- were inhabited and we had no negative information on the variable!-          -- So only refine delta if we find that one branch was indeed-          -- uninhabited.-          let neg = lookupRefuts delta x-          case (ev_pos, ev_neg) of-            ([], _)       -> pure ev_neg-            (_, [])       -> pure ev_pos-            _ | null neg  -> pure [delta]-              | otherwise -> pure (ev_pos ++ ev_neg)---- | Checks if every data con of the type 'isVanillaDataCon'.-isVanillaDataType :: Type -> Bool-isVanillaDataType ty = fromMaybe False $ do-  (tc, _) <- splitTyConApp_maybe ty-  dcs <- tyConDataCons_maybe tc-  pure (all isVanillaDataCon dcs)---- 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-    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 }-      -- TODO: Think about how to recognize PatSyns-      | Var y <- e, not (isDataConWorkId x)-      = modifyT (\delta -> addVarVarCt delta (x, y))-      | otherwise-      -- TODO: Use a CoreMap to identify the CoreExpr with a unique representant-      = pure ()-      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--    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
− compiler/deSugar/PmPpr.hs 
@@ -1,220 +0,0 @@-{-# LANGUAGE CPP, ViewPatterns #-}---- | Provides factilities for pretty-printing 'Delta's in a way appropriate for--- user facing pattern match warnings.-module PmPpr (-        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 PmTypes-import PmOracle---- | 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/ghci/ByteCodeGen.hs view
@@ -86,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.@@ -158,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
compiler/ghci/ByteCodeInstr.hs view
@@ -10,7 +10,6 @@   ) where  #include "HsVersions.h"-#include "../includes/MachDeps.h"  import GhcPrelude
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@@ -1178,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.@@ -1524,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/iface/BinIface.hs view
@@ -10,6 +10,7 @@  -- | Binary interface file support. module BinIface (+        -- * Public API for interface file serialisation         writeBinIface,         readBinIface,         getSymtabName,@@ -17,7 +18,16 @@         CheckHiWay(..),         TraceBinIFaceReading(..),         getWithUserData,-        putWithUserData+        putWithUserData,++        -- * Internal serialisation functions+        getSymbolTable,+        putName,+        putDictionary,+        putFastString,+        putSymbolTable,+        BinSymbolTable(..),+        BinDictionary(..)      ) where
compiler/iface/BuildTyCl.hs view
@@ -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)
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@@ -399,7 +400,7 @@        -- Redo search for our local hole module        loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from   | otherwise-  = withTimingSilent getDynFlags (text "loading interface") (pure ()) $+  = withTimingSilentD (text "loading interface") (pure ()) $     do  {       -- Read the state           (eps,hpt) <- getEpsAndHpt         ; gbl_env <- getGblEnv@@ -422,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 }@@ -965,7 +966,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")@@ -1039,13 +1040,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)@@ -1118,21 +1121,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, @@ -135,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 (mi_decls 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,@@ -210,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@@ -218,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@@ -230,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@@ -277,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,@@ -363,9 +332,6 @@          | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env          | otherwise                                   = Nothing -     deliberatelyOmitted :: String -> a-     deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)-      ifFamInstTcName = ifFamInstFam  -----------------------------@@ -409,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))  -- ---------------------------------------------------------------------------@@ -443,17 +409,16 @@ -- See Note [Fingerprinting IfaceDecls] addFingerprints         :: HscEnv-        -> Maybe Fingerprint -- the old fingerprint, if any-        -> ModIface          -- The new interface (lacking decls)+        -> PartialModIface   -- 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+        -> IO ModIface       -- Updated interface+addFingerprints hsc_env iface0 new_decls  = do    eps <- hscEPS hsc_env    let+       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.@@ -719,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@@ -747,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@@ -789,11 +754,11 @@     dflags     = hsc_dflags hsc_env     get_orph_hash mod =           case lookupIfaceByModule dflags hpt pit mod of-            Just iface -> return (mi_orphan_hash iface)+            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@@ -1327,7 +1292,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@@ -1424,7 +1389,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@@ -1437,7 +1402,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@@ -1452,7 +1417,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@@ -1635,7 +1600,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@@ -1644,7 +1609,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,@@ -1656,9 +1621,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"
compiler/llvmGen/LlvmCodeGen.hs view
@@ -45,7 +45,7 @@                -> Stream.Stream IO RawCmmGroup a                -> IO a llvmCodeGen dflags h us cmm_stream-  = withTiming (pure dflags) (text "LLVM CodeGen") (const ()) $ do+  = withTiming dflags (text "LLVM CodeGen") (const ()) $ do        bufh <- newBufHandle h         -- Pass header@@ -94,11 +94,17 @@     header :: SDoc     header = sdocWithDynFlags $ \dflags ->       let target = platformMisc_llvmTarget $ platformMisc dflags-          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 ++ "\"")+      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
compiler/llvmGen/LlvmCodeGen/Data.hs view
@@ -71,6 +71,7 @@     label <- strCLabel_llvm lbl     static <- mapM genData xs     lmsec <- llvmSection sec+    platform <- getLlvmPlatform     let types   = map getStatType static          strucTy = LMStruct types@@ -79,7 +80,8 @@         struct         = Just $ LMStaticStruc static tyAlias         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
compiler/llvmGen/LlvmMangler.hs view
@@ -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/CodeOutput.hs view
@@ -71,7 +71,7 @@                     else cmm_stream                do_lint cmm = withTimingSilent-                  (pure dflags)+                  dflags                   (text "CmmLint"<+>brackets (ppr this_mod))                   (const ()) $ do                 { case cmmLint dflags cmm of@@ -118,7 +118,7 @@  outputC dflags filenm cmm_stream packages   = do-       withTiming (return dflags) (text "C codegen") (\a -> seq a () {- FIXME -}) $ do+       withTiming dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do           -- figure out which header files to #include in the generated .hc file:          --@@ -224,12 +224,12 @@              -- wrapper code mentions the ffi_arg type, which comes from ffi.h             ffi_includes-              | platformMisc_libFFI $ platformMisc dflags = "#include \"ffi.h\"\n"+              | 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@@ -237,7 +237,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)
compiler/main/DriverPipeline.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-}-{-# OPTIONS_GHC -fno-cse #-}--- -fno-cse is needed for GLOBAL_VAR's to behave properly  ----------------------------------------------------------------------------- --@@ -33,6 +31,7 @@    linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode   ) where +#include <ghcplatform.h> #include "HsVersions.h"  import GhcPrelude@@ -77,6 +76,7 @@ import Data.Maybe import Data.Version import Data.Either      ( partitionEithers )+import Data.IORef  import Data.Time        ( UTCTime ) @@ -156,11 +156,15 @@     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, m_iface) <- hscIncrementalCompile                         always_do_basic_recompilation_check                         m_tc_result mHscMessage                         hsc_env summary source_modified mb_old_iface (mod_index, nmods) +   -- Build HMI from the results of the Core pipeline.+   let coreHmi m_linkable = HomeModInfo (expectIface m_iface) hmi_details m_linkable+    let flags = hsc_dflags hsc_env0      in do unless (gopt Opt_KeepHiFiles flags) $                addFilesToClean flags TFL_CurrentModule $@@ -173,23 +177,23 @@         (HscUpToDate, _) ->             -- TODO recomp014 triggers this assert. What's going on?!             -- ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) )-            return hmi0 { hm_linkable = maybe_old_linkable }+            return $! coreHmi maybe_old_linkable         (HscNotGeneratingCode, 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 }+            in return $! coreHmi mb_linkable         (HscNotGeneratingCode, _) -> panic "compileOne HscNotGeneratingCode"         (_, HscNothing) -> panic "compileOne HscNothing"         (HscUpdateBoot, HscInterpreted) -> do-            return hmi0+            return $! coreHmi Nothing         (HscUpdateBoot, _) -> do             touchObjectFile dflags object_filename-            return hmi0+            return $! coreHmi Nothing         (HscUpdateSig, HscInterpreted) ->-            let linkable = LM (ms_hs_date summary) this_mod []-            in return hmi0 { hm_linkable = Just linkable }+            let !linkable = LM (ms_hs_date summary) this_mod []+            in return $! coreHmi (Just linkable)         (HscUpdateSig, _) -> do             output_fn <- getOutputFilename next_phase                             (Temporary TFL_CurrentModule) basename dflags@@ -208,9 +212,16 @@                               (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+            let !linkable = LM o_time this_mod [DotO object_filename]+            return $! coreHmi $ Just linkable+        (HscRecomp cgguts summary iface_gen, HscInterpreted) -> do+            -- In interpreted mode the regular codeGen backend is not run+            -- so we generate a interface without codeGen info.+            (iface, no_change) <- iface_gen+            -- If we interpret the code, then we can write the interface file here.+            liftIO $ hscMaybeWriteIface dflags iface no_change+                                (ms_location summary)+             (hasStub, comp_bc, spt_entries) <-                 hscInteractive hsc_env cgguts summary @@ -228,29 +239,44 @@               -- 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 iface hmi_details (Just linkable)+        (HscRecomp cgguts summary iface_gen, _) -> do             output_fn <- getOutputFilename next_phase                             (Temporary TFL_CurrentModule)                             basename dflags next_phase (Just location)             -- We're in --make mode: finish the compilation pipeline.++            -- We use this IORef the get out the iface from the otherwise+            -- opaque pipeline once it's created. Otherwise we would have+            -- to thread it through runPipeline.+            if_ref <- newIORef Nothing :: IO (IORef (Maybe ModIface))+            let iface_gen' = do+                    res@(iface, _no_change) <- iface_gen+                    writeIORef if_ref $ Just iface+                    return res+             _ <- runPipeline StopLn hsc_env                               (output_fn,                                Nothing,-                               Just (HscOut src_flavour mod_name (HscRecomp cgguts summary)))+                               Just (HscOut src_flavour mod_name+                                        (HscRecomp cgguts summary iface_gen')))                               (Just basename)                               Persistent                               (Just location)                               []+            iface <- (expectJust "Iface callback") <$> readIORef if_ref                   -- 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 +       expectIface :: Maybe ModIface -> ModIface+       expectIface = expectJust "compileOne': Interface expected "+        this_mod    = ms_mod summary        location    = ms_location summary        input_fn    = expectJust "compile:hs" (ml_hs_file location)@@ -735,17 +761,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)@@ -868,7 +899,7 @@     ++ [("", "-mattr=" ++ attrs) | not (null attrs) ]    where target = platformMisc_llvmTarget $ platformMisc dflags-        Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets dflags)+        Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets $ llvmConfig dflags)          -- Relocation models         rmodel | gopt Opt_PIC dflags        = "pic"@@ -1112,7 +1143,7 @@    -- run the compiler!         let msg hsc_env _ what _ = oneShotMsg hsc_env what-        (result, _) <- liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'+        (result, _, _) <- liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'                             mod_summary source_unchanged Nothing (1,1)          return (HscOut src_flavour mod_name result,@@ -1149,13 +1180,22 @@                        basename = dropExtension input_fn                    liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name                    return (RealPhase StopLn, o_file)-            HscRecomp cgguts mod_summary+            HscRecomp cgguts mod_summary iface_gen               -> 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+++                    (iface, no_change) <- liftIO iface_gen++                    -- See Note [Writing interface files]+                    let if_dflags = dflags `gopt_unset` Opt_BuildDynamicToo+                    liftIO $ hscMaybeWriteIface if_dflags iface no_change+                                                    (ms_location mod_summary)+                     stub_o <- liftIO (mapM (compileStub hsc_env') mStub)                     foreign_os <- liftIO $                       mapM (uncurry (compileForeign hsc_env')) foreign_files@@ -1408,7 +1448,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 "
compiler/main/DynamicLoading.hs view
@@ -3,7 +3,6 @@ -- | Dynamically lookup up values from modules and loading them. module DynamicLoading (         initializePlugins,-#if defined(HAVE_INTERPRETER)         -- * Loading plugins         loadFrontendPlugin, @@ -19,15 +18,11 @@         getValueSafely,         getHValueSafely,         lessUnsafeCoerce-#else-        pluginError-#endif     ) where  import GhcPrelude import DynFlags -#if defined(HAVE_INTERPRETER) import Linker           ( linkModule, getHValue ) import GHCi             ( wormhole ) import SrcLoc           ( noSrcSpan )@@ -60,28 +55,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(HAVE_INTERPRETER)-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 +69,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(HAVE_INTERPRETER)+  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 +280,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/GHC.hs view
@@ -85,7 +85,7 @@         lookupGlobalName,         findGlobalAnns,         mkPrintUnqualifiedForModule,-        ModIface(..),+        ModIface, ModIface_(..),         SafeHaskellMode(..),          -- * Querying the environment@@ -311,6 +311,7 @@ import TcRnMonad        ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) import LoadIface        ( loadSysInterface ) import TcRnTypes+import Predicate import Packages import NameSet import RdrName@@ -505,7 +506,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
compiler/main/GhcMake.hs view
@@ -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))])
compiler/main/HscMain.hs view
@@ -39,6 +39,7 @@     , Messager, batchMsg     , HscStatus (..)     , hscIncrementalCompile+    , hscMaybeWriteIface     , hscCompileCmmFile      , hscGenHardCode@@ -75,7 +76,7 @@       -- hscFileFrontEnd in client code     , hscParse', hscSimplify', hscDesugar', tcRnModule'     , getHscEnv-    , hscSimpleIface', hscNormalIface'+    , hscSimpleIface'     , oneShotMsg     , hscFileFrontEnd, genericHscFrontend, dumpIfaceStats     , ioMsgMaybe@@ -172,6 +173,7 @@ 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, hie_module )@@ -329,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@@ -672,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) ->@@ -713,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@@ -722,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, Maybe ModIface) hscIncrementalCompile always_do_basic_recompilation_check m_tc_result     mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index   = do@@ -753,22 +756,19 @@         -- 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, details, Just iface)         -- 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@@ -776,15 +776,22 @@         Right (FrontendTypecheck tc_result, mb_old_hash) ->             finish mod_summary tc_result mb_old_hash --- 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, Maybe ModIface) finish summary tc_result mb_old_hash = do   hsc_env <- getHscEnv   let dflags = hsc_dflags hsc_env@@ -792,6 +799,7 @@       hsc_src = ms_hsc_src summary       should_desugar =         ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile+      mk_simple_iface :: Hsc (HscStatus, ModDetails, Maybe ModIface)       mk_simple_iface = do         let hsc_status =               case (target, hsc_src) of@@ -801,41 +809,74 @@                 _ -> 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}) -hscMaybeWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()-hscMaybeWriteIface dflags iface no_change summary =+        liftIO $ hscMaybeWriteIface dflags iface no_change (ms_location summary)+        return (hsc_status, details, Just iface)++  -- 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++          (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)++          let iface_gen :: IO (ModIface, Bool)+              iface_gen = do+                  -- Build a fully instantiated ModIface.+                  -- This has to happen *after* code gen so that the back-end+                  -- info has been set.+                  -- This captures hsc_env, but it seems we keep it alive in other+                  -- ways as well so we don't bother extracting only the relevant parts.+                  dumpIfaceStats hsc_env+                  final_iface <- mkFullIface hsc_env partial_iface+                  let no_change = mb_old_hash == Just (mi_iface_hash (mi_final_exts final_iface))+                  return (final_iface, no_change)++          return ( HscRecomp cg_guts summary iface_gen+                 , details, Nothing )+    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 -> Bool -> ModLocation -> IO ()+hscMaybeWriteIface dflags iface no_change location =     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+            hscWriteIface dflags iface no_change location  -------------------------------------------------------------- -- NoRecomp handlers@@ -1295,6 +1336,8 @@ -- 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@@ -1309,63 +1352,64 @@     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+    let no_change = mb_old_iface == Just (mi_iface_hash (mi_final_exts new_iface))     -- 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--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                -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)])@@ -1409,7 +1453,7 @@         -- 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 "StgToCmm" #-}@@ -1504,8 +1548,7 @@     let dflags = hsc_dflags hsc_env      let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds-    dumpIfSet_dyn dflags Opt_D_dump_stg_final-                  "STG for code gen:" (pprGenStgTopBindings stg_binds_w_fvs)+     let cmm_stream :: Stream IO CmmGroup ()         cmm_stream = {-# SCC "StgToCmm" #-}             StgToCmm.codeGen dflags this_mod data_tycons@@ -1806,7 +1849,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
compiler/main/InteractiveEval.hs view
@@ -63,6 +63,9 @@ import Type             hiding( typeKind ) import RepType import TcType+import Constraint+import TcOrigin+import Predicate import Var import Id import Name             hiding ( varName )
compiler/main/SysTools.hs view
@@ -13,7 +13,7 @@ module SysTools (         -- * Initialisation         initSysTools,-        initLlvmConfig,+        lazyInitLlvmConfig,          -- * Interface to system tools         module SysTools.Tasks,@@ -44,22 +44,20 @@  import Module import Packages-import Config import Outputable import ErrUtils import GHC.Platform import DynFlags-import Fingerprint-import ToolSettings -import qualified Data.Map as Map+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]@@ -113,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@@ -137,215 +156,12 @@                                 --      (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 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-       settingsList <- case maybeReadFuzzy settingsStr of-                     Just s ->-                         return s-                     Nothing ->-                         pgmError ("Can't parse " ++ show settingsFile)-       let mySettings = Map.fromList settingsList-       platformConstants <- case maybeReadFuzzy platformConstantsStr of-                            Just s ->-                                return s-                            Nothing ->-                                pgmError ("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 -> IO String-           getToolSetting key = expandToolDir mtool_dir <$> getSetting key-           getBooleanSetting :: String -> IO 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"--       tmpdir <- 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-         }-+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]
compiler/main/SysTools/ExtraObj.hs view
@@ -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/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
@@ -371,4 +371,4 @@ --   to run GHC with @-v2@ or @-ddump-timings@. traceToolCommand :: DynFlags -> String -> IO a -> IO a traceToolCommand dflags tool = withTiming-  (return dflags) (text $ "systool:" ++ tool) (const ())+  dflags (text $ "systool:" ++ tool) (const ())
compiler/main/TidyPgm.hs view
@@ -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'@@ -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
compiler/nativeGen/AsmCodeGen.hs view
@@ -168,6 +168,7 @@       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"@@ -334,7 +335,7 @@                 -> NativeGenAcc statics instr                 -> IO UniqSupply finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs- = withTimingSilent (return dflags) (text "NCG") (`seq` ()) $ do+ = withTimingSilent dflags (text "NCG") (`seq` ()) $ do         -- Write debug data and finish         let emitDw = debugLevel dflags > 0         us' <- if not emitDw then return us else do@@ -403,7 +404,7 @@         Right (cmms, cmm_stream') -> do           (us', ngs'') <-             withTimingSilent-                (return dflags)+                dflags                 ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do               -- Generate debug information               let debugFlag = debugLevel dflags > 0@@ -534,6 +535,10 @@  = do         let platform = targetPlatform dflags +        let proc_name = case cmm of+                (CmmProc _ entry_label _ _) -> ppr entry_label+                _                           -> text "DataChunk"+         -- rewrite assignments to global regs         let fixed_cmm =                 {-# SCC "fixStgRegisters" #-}@@ -558,17 +563,15 @@                                         (cmmTopCodeGen ncgImpl)                                         fileIds dbgMap opt_cmm cmmCfg -         dumpIfSet_dyn dflags                 Opt_D_dump_asm_native "Native code"                 (vcat $ map (pprNatCmmDecl ncgImpl) native) -        dumpIfSet_dyn dflags-                Opt_D_dump_cfg_weights "CFG Weights"-                (pprEdgeWeights nativeCfgWeights)+        maybeDumpCfg dflags (Just nativeCfgWeights) "CFG Weights - Native" proc_name          -- tag instructions with register liveness information-        -- also drops dead code+        -- also drops dead code. We don't keep the cfg in sync on+        -- some backends, so don't use it there.         let livenessCfg = if (backendMaintainsCfg dflags)                                 then Just nativeCfgWeights                                 else Nothing@@ -679,19 +682,20 @@             cfgRegAllocUpdates = (concatMap Linear.ra_fixupList raStats)          let cfgWithFixupBlks =-                addNodesBetween nativeCfgWeights cfgRegAllocUpdates+                (\cfg -> addNodesBetween cfg cfgRegAllocUpdates) <$> livenessCfg          -- Insert stack update blocks         let postRegCFG =-                foldl' (\m (from,to) -> addImmediateSuccessor from to m )-                       cfgWithFixupBlks stack_updt_blks+                pure (foldl' (\m (from,to) -> addImmediateSuccessor from to m ))+                     <*> cfgWithFixupBlks+                     <*> pure stack_updt_blks          ---- generate jump tables         let tabled      =                 {-# SCC "generateJumpTables" #-}                 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 )@@ -701,12 +705,11 @@                 {-# SCC "shortcutBranches" #-}                 shortcutBranches dflags ncgImpl tabled postRegCFG -        let optimizedCFG =-                optimizeCFG (cfgWeightInfo dflags) cmm postShortCFG+        let optimizedCFG :: Maybe CFG+            optimizedCFG =+                optimizeCFG (cfgWeightInfo dflags) cmm <$!> postShortCFG -        dumpIfSet_dyn dflags-                Opt_D_dump_cfg_weights "CFG Final Weights"-                ( pprEdgeWeights optimizedCFG )+        maybeDumpCfg dflags optimizedCFG "CFG Weights - Final" proc_name          --TODO: Partially check validity of the cfg.         let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks@@ -716,7 +719,8 @@                 (gopt Opt_DoAsmLinting dflags || debugIsOn )) $ do                 let blocks = concatMap getBlks shorted                 let labels = setFromList $ fmap blockId blocks :: LabelSet-                return $! seq (sanityCheckCfg optimizedCFG labels $+                let cfg = fromJust optimizedCFG+                return $! seq (sanityCheckCfg cfg labels $                                 text "cfg not in lockstep") ()          ---- sequence blocks@@ -734,7 +738,9 @@                 {-# SCC "invertCondBranches" #-}                 map invert sequenced               where-                invertConds = (invertCondBranches ncgImpl) optimizedCFG+                invertConds :: LabelMap CmmStatics -> [NatBasicBlock instr]+                            -> [NatBasicBlock instr]+                invertConds = invertCondBranches ncgImpl optimizedCFG                 invert top@CmmData {} = top                 invert (CmmProc info lbl live (ListGraph blocks)) =                     CmmProc info lbl live (ListGraph $ invertConds info blocks)@@ -766,6 +772,15 @@                 , ppr_raStatsLinear                 , unwinds ) +maybeDumpCfg :: DynFlags -> Maybe CFG -> String -> SDoc -> IO ()+maybeDumpCfg _dflags Nothing _ _ = return ()+maybeDumpCfg dflags (Just cfg) msg proc_name+        | null cfg = return ()+        | otherwise+        = dumpIfSet_dyn+                dflags Opt_D_dump_cfg_weights msg+                (proc_name <> char ':' $$ pprEdgeWeights cfg)+ -- | Make sure all blocks we want the layout algorithm to place have been placed. checkLayout :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]             -> [NatCmmDecl statics instr]@@ -884,13 +899,13 @@         :: forall statics instr jumpDest. (Outputable jumpDest) => DynFlags         -> NcgImpl statics instr jumpDest         -> [NatCmmDecl statics instr]-        -> CFG-        -> ([NatCmmDecl statics instr],CFG)+        -> Maybe CFG+        -> ([NatCmmDecl statics instr],Maybe CFG)  shortcutBranches dflags ncgImpl tops weights   | gopt Opt_AsmShortcutting dflags   = ( map (apply_mapping ncgImpl mapping) tops'-    , shortcutWeightMap weights mappingBid )+    , shortcutWeightMap mappingBid <$!> weights )   | otherwise   = (tops, weights)   where
compiler/nativeGen/BlockLayout.hs view
@@ -6,6 +6,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}  module BlockLayout     ( sequenceTop )@@ -22,7 +24,6 @@ import Cmm import Hoopl.Collections import Hoopl.Label-import Hoopl.Block  import DynFlags (gopt, GeneralFlag(..), DynFlags, backendMaintainsCfg) import UniqFM@@ -41,11 +42,30 @@ import OrdList import Data.List import Data.Foldable (toList)-import Hoopl.Graph  import qualified Data.Set as Set+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]   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -60,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: @@ -81,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:@@ -141,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:@@ -204,11 +247,6 @@ 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]))@@ -224,40 +262,24 @@ newtype BlockChain     = BlockChain { chainBlocks :: (OrdList BlockId) } -instance Eq (BlockChain) where-    (BlockChain blks1) == (BlockChain blks2)-        = fromOL blks1 == fromOL blks2+-- 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)-       = (fromOL lbls1) `compare` (fromOL lbls2)+       = ASSERT(toList lbls1 /= toList lbls2 || lbls1 `strictlyEqOL` lbls2)+         strictlyOrdOL lbls1 lbls2  instance Outputable (BlockChain) where     ppr (BlockChain blks) =         parens (text "Chain:" <+> ppr (fromOL $ blks) ) -data WeightedEdge = WeightedEdge !BlockId !BlockId EdgeWeight deriving (Eq)----- | 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--instance Outputable WeightedEdge where-    ppr (WeightedEdge from to info) =-        ppr from <> text "->" <> ppr to <> brackets (ppr info)--type WeightedEdgeList = [WeightedEdge]+chainFoldl :: (b -> BlockId -> b) -> b -> BlockChain -> b+chainFoldl f z (BlockChain blocks) = foldl' f z blocks  noDups :: [BlockChain] -> Bool noDups chains =@@ -270,19 +292,21 @@ inFront bid (BlockChain seq)   = headOL seq == bid -chainMember :: BlockId -> BlockChain -> Bool-chainMember bid chain-  = elem bid $ fromOL . chainBlocks $ chain---   = setMember bid . chainMembers $ chain- chainSingleton :: BlockId -> BlockChain chainSingleton lbl     = BlockChain (unitOL lbl) +chainFromList :: [BlockId] -> BlockChain+chainFromList = BlockChain . toOL+ chainSnoc :: BlockChain -> BlockId -> BlockChain 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 blks1) (BlockChain blks2)   = BlockChain (blks1 `appOL` blks2)@@ -311,52 +335,14 @@ takeL n (BlockChain blks) =     take n . fromOL $ 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 -> (headOL . chainBlocks $ 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 = headOL . chainBlocks $ newChain-                  end = lastOL . chainBlocks $ 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-+-- 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.@@ -365,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.@@ -375,14 +361,22 @@ -- 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@@ -396,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@@ -437,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 :: Extensibility) (x :: Extensibility) = 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 fromOL $ map chainBlocks prepedChains)+            = ASSERT(noDups [masterChain])+              (concatMap fromOL $ map chainBlocks prepedChains)          --chainPlaced = setFromList $ map blockId blockList :: LabelSet         chainPlaced = setFromList $ blockList :: LabelSet@@ -605,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 _    [] = []@@ -638,29 +774,30 @@  sequenceTop     :: (Instruction instr, Outputable instr)-    => DynFlags --Use new layout code-    -> NcgImpl statics instr jumpDest -> CFG-    -> NatCmmDecl statics instr -> NatCmmDecl statics instr+    => DynFlags -- Determine which layout algo to use+    -> NcgImpl statics instr jumpDest+    -> Maybe CFG -- ^ CFG if we have one.+    -> NatCmmDecl statics instr -- ^ Function to serialize+    -> NatCmmDecl statics instr  sequenceTop _     _       _           top@(CmmData _ _) = top sequenceTop dflags ncgImpl edgeWeights             (CmmProc info lbl live (ListGraph blocks))   | (gopt Opt_CfgBlocklayout dflags) && backendMaintainsCfg dflags   --Use chain based algorithm+  , Just cfg <- edgeWeights   = CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $-                            sequenceChain info edgeWeights blocks )+                            {-# SCC layoutBlocks #-}+                            sequenceChain info cfg blocks )   | otherwise   --Use old algorithm-  = CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $-                            sequenceBlocks cfg info blocks)+  = let cfg = if dontUseCfg then Nothing else edgeWeights+    in  CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $+                                {-# SCC layoutBlocks #-}+                                sequenceBlocks cfg info blocks)   where-    cfg-      | (gopt Opt_WeightlessBlocklayout dflags) ||-        (not $ backendMaintainsCfg dflags)-      -- Don't make use of cfg in the old algorithm-      = Nothing-      -- Use cfg in the old algorithm-      | otherwise = Just edgeWeights+    dontUseCfg = gopt Opt_WeightlessBlocklayout dflags ||+                 (not $ backendMaintainsCfg dflags)  -- The old algorithm: -- It is very simple (and stupid): We make a graph out of
compiler/nativeGen/CFG.hs view
@@ -6,31 +6,40 @@ {-# 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 "HsVersions.h"@@ -38,9 +47,8 @@ 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,32 +58,63 @@  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 () -- For Outputable instances import qualified DynFlags as D  import Data.List+import Data.STRef.Strict+import Control.Monad.ST --- import qualified Data.IntMap.Strict as M --TODO: LabelMap+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)  -- | A control flow graph where edges have been annotated with a weight.+-- Implemented as IntMap (IntMap <edgeData>)+-- We must uphold the invariant that for each edge A -> B we must have:+-- A entry B in the outer map.+-- A entry B in the map we get when looking up A.+-- Maintaining this invariant is useful as any failed lookup now indicates+-- an actual error in code which might go unnoticed for a while+-- otherwise. type CFG = EdgeInfoMap EdgeInfo  data CfgEdge@@ -108,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@@ -127,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.@@ -140,16 +190,36 @@                  -> 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 -getCfgNodes :: CFG -> LabelSet-getCfgNodes m = mapFoldMapWithKey (\k v -> setFromList (k:mapKeys v)) m+-- | 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 -> [BlockId]+getCfgNodes m =+    mapKeys m++-- | Is this block part of this graph? hasNode :: CFG -> BlockId -> Bool-hasNode m node = mapMember node m || any (mapMember node) m+hasNode m node =+  -- Check the invariant that each node must exist in the first map or not at all.+  ASSERT( found || not (any (mapMember node) m))+  found+    where+      found = mapMember node m ++ -- | Check if the nodes in the cfg and the set of blocks are the same. --   In a case of a missmatch we panic and show the difference. sanityCheckCfg :: CFG -> LabelSet -> SDoc -> Bool@@ -160,11 +230,11 @@         pprPanic "Block list and cfg nodes don't match" (             text "difference:" <+> ppr diff $$             text "blocks:" <+> ppr blockSet $$-            text "cfg:" <+> ppr m $$+            text "cfg:" <+> pprEdgeWeights m $$             msg )             False     where-      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.@@ -224,8 +294,8 @@ applies the mapping to the CFG in the way layed out above.  -}-shortcutWeightMap :: CFG -> LabelMap (Maybe BlockId) -> CFG-shortcutWeightMap cfg cuts =+shortcutWeightMap :: LabelMap (Maybe BlockId) -> CFG -> CFG+shortcutWeightMap cuts cfg =   foldl' applyMapping cfg $ mapToList cuts     where -- takes the tuple (B,C) from the notation in [Updating the CFG during shortcutting]@@ -275,11 +345,17 @@ -- | Adds a new edge, overwrites existing edges if present addEdge :: BlockId -> BlockId -> EdgeInfo -> CFG -> CFG addEdge from to info cfg =-    mapAlter addDest from cfg+    mapAlter addFromToEdge from $+    mapAlter addDestNode to cfg     where-        addDest Nothing = Just $ mapSingleton to info-        addDest (Just wm) = Just $ mapInsert to info wm+        -- Simply insert the edge into the edge list.+        addFromToEdge Nothing = Just $ mapSingleton to info+        addFromToEdge (Just wm) = Just $ mapInsert to info wm+        -- We must add the destination node explicitly+        addDestNode Nothing = Just $ mapEmpty+        addDestNode n@(Just _) = n + -- | Adds a edge with the given weight to the cfg --   If there already existed an edge it is overwritten. --   `addWeightEdge from to weight cfg`@@ -294,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 =@@ -304,8 +385,11 @@         sortedEdges  -- | Get successors of a given node with edge weights.-getSuccessorEdges :: CFG -> BlockId -> [(BlockId,EdgeInfo)]-getSuccessorEdges m bid = maybe [] mapToList $ mapLookup bid m+getSuccessorEdges :: HasDebugCallStack => CFG -> BlockId -> [(BlockId,EdgeInfo)]+getSuccessorEdges m bid = maybe lookupError mapToList (mapLookup bid m)+  where+    lookupError = pprPanic "getSuccessorEdges: Block does not exist" $+                    ppr bid <+> pprEdgeWeights m  getEdgeInfo :: BlockId -> BlockId -> CFG -> Maybe EdgeInfo getEdgeInfo from to m@@ -315,48 +399,69 @@     | 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 = foldr add mapEmpty flatElems+reverseEdges cfg = mapFoldlWithKey (\cfg from toMap -> go (addNode cfg from) from toMap) mapEmpty cfg   where-    elems = mapToList $ fmap mapToList cfg :: [(BlockId,[(BlockId,EdgeInfo)])]-    flatElems =-        concatMap (\(from,ws) -> map (\(to,info) -> (to,from,info)) ws ) elems-    add (to,from,info) m = addEdge to from info m+    -- We 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 :: CFG -> BlockId -> [BlockId]+getSuccessors :: HasDebugCallStack => CFG -> BlockId -> [BlockId] getSuccessors m bid     | Just wm <- mapLookup bid m     = mapKeys wm-    | otherwise = []+    | otherwise = lookupError+    where+      lookupError = pprPanic "getSuccessors: Block does not exist" $+                    ppr bid <+> pprEdgeWeights m  pprEdgeWeights :: CFG -> SDoc pprEdgeWeights m =-    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"@@ -365,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@@ -375,11 +480,12 @@     text "}\n"  {-# INLINE updateEdgeWeight #-} --Allows eliminating the tuple when possible+-- | Invariant: The edge **must** exist already in the graph. updateEdgeWeight :: (EdgeWeight -> EdgeWeight) -> Edge -> CFG -> CFG updateEdgeWeight f (from, to) cfg     | Just oldInfo <- getEdgeInfo from to cfg-    = 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"@@ -422,7 +528,8 @@         | otherwise         = pprPanic "Can't find weight for edge that should have one" (             text "triple" <+> ppr (from,between,old) $$-            text "updates" <+> ppr updates )+            text "updates" <+> ppr updates $$+            text "cfg:" <+> pprEdgeWeights m )       updateWeight :: CFG -> (BlockId,BlockId,BlockId,EdgeInfo) -> CFG       updateWeight m (from,between,old,edgeInfo)         = addEdge from between edgeInfo .@@ -447,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@@ -478,7 +583,6 @@           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@@ -514,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@@ -538,14 +653,14 @@             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      blocks = revPostorder graph :: [CmmBlock]  --Find back edges by BFS-findBackEdges :: BlockId -> CFG -> Edges+findBackEdges :: HasDebugCallStack => BlockId -> CFG -> Edges findBackEdges root cfg =     --pprTraceIt "Backedges:" $     map fst .@@ -560,6 +675,11 @@ 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@@ -589,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@@ -611,41 +727,595 @@               | 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.-loopMembers :: CFG -> LabelMap Bool+--   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      setLevel :: SCC BlockId -> LabelMap Bool -> LabelMap Bool     setLevel (AcyclicSCC bid) m = mapInsert bid False m     setLevel (CyclicSCC bids) m = foldl' (\m k -> mapInsert k True m) m bids++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/NCGMonad.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE BangPatterns #-}  -- ----------------------------------------------------------------------------- --@@ -88,7 +89,7 @@     -- the block's 'UnwindPoint's     -- See Note [What is this unwinding business?] in Debug     -- and Note [Unwinding information in the NCG] in this module.-    invertCondBranches        :: CFG -> LabelMap CmmStatics -> [NatBasicBlock instr]+    invertCondBranches        :: Maybe CFG -> LabelMap CmmStatics -> [NatBasicBlock instr]                               -> [NatBasicBlock instr]     -- ^ Turn the sequence of `jcc l1; jmp l2` into `jncc l2; <block_l1>`     -- when possible.@@ -204,7 +205,8 @@  updateCfgNat :: (CFG -> CFG) -> NatM () updateCfgNat f-        = NatM $ \ st -> ((), st { natm_cfg = f (natm_cfg st) })+        = NatM $ \ st -> let !cfg' = f (natm_cfg st)+                         in ((), st { natm_cfg = cfg'})  -- | Record that we added a block between `from` and `old`. addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM ()
compiler/nativeGen/PIC.hs view
@@ -565,7 +565,7 @@ --  pprImportedSymbol :: DynFlags -> Platform -> CLabel -> SDoc-pprImportedSymbol dflags (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 ->@@ -618,7 +618,7 @@         = empty  -pprImportedSymbol _ (Platform { platformOS = OSDarwin }) _+pprImportedSymbol _ (Platform { platformMini = PlatformMini { platformMini_os = OSDarwin } }) _         = empty  -- XCOFF / AIX@@ -632,7 +632,7 @@ -- -- NB: No DSO-support yet -pprImportedSymbol dflags (Platform { platformOS = OSAIX }) importedLbl+pprImportedSymbol dflags (Platform { platformMini = PlatformMini { platformMini_os = OSAIX } }) importedLbl         = case dynamicLinkerLabelInfo importedLbl of             Just (SymbolPtr, lbl)               -> vcat [@@ -669,7 +669,7 @@ -- the NCG will keep track of all DynamicLinkerLabels it uses -- and output each of them using pprImportedSymbol. -pprImportedSymbol dflags platform@(Platform { platformArch = ArchPPC_64 _ })+pprImportedSymbol dflags platform@(Platform { platformMini = PlatformMini { platformMini_arch = ArchPPC_64 _ } })                   importedLbl         | osElfTarget (platformOS platform)         = case dynamicLinkerLabelInfo importedLbl of
compiler/nativeGen/PPC/CodeGen.hs view
@@ -21,7 +21,6 @@ where  #include "HsVersions.h"-#include "../includes/MachDeps.h"  -- NCG stuff: import GhcPrelude
compiler/nativeGen/RegAlloc/Graph/SpillCost.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables, GADTs, BangPatterns #-} module RegAlloc.Graph.SpillCost (         SpillCostRecord,         plusSpillCostRecord,@@ -23,6 +23,7 @@ import GraphBase  import Hoopl.Collections (mapLookup)+import Hoopl.Label import Cmm import UniqFM import UniqSet@@ -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)+        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/TrivColorable.hs view
@@ -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@@ -149,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@@ -181,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
compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs view
@@ -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
@@ -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/Liveness.hs view
@@ -705,8 +705,8 @@         reachable :: LabelSet         reachable             | Just cfg <- mcfg-            -- Our CFG only contains reachable nodes by construction.-            = getCfgNodes cfg+            -- Our CFG only contains reachable nodes by construction at this point.+            = setFromList $ getCfgNodes cfg             | otherwise             = setFromList $ [ node_key node | node <- reachablesG g1 roots ]
compiler/nativeGen/SPARC/CodeGen.hs view
@@ -18,7 +18,6 @@ where  #include "HsVersions.h"-#include "../includes/MachDeps.h"  -- NCG stuff: import GhcPrelude
compiler/nativeGen/TargetReg.hs view
@@ -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,4 +1,6 @@ {-# LANGUAGE CPP, GADTs, NondecreasingIndentation #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE BangPatterns #-}  #if __GLASGOW_HASKELL__ <= 808 -- GHC 8.10 deprecates this flag, but GHC 8.8 needs it@@ -30,7 +32,6 @@ where  #include "HsVersions.h"-#include "../includes/MachDeps.h"  -- NCG stuff: import GhcPrelude@@ -38,6 +39,7 @@ import X86.Instr import X86.Cond import X86.Regs+import X86.Ppr (  ) import X86.RegInfo  import GHC.Platform.Regs@@ -136,7 +138,57 @@ cmmTopCodeGen (CmmData sec dat) = do   return [CmmData sec (mkAlignment 1, dat)]  -- no translation, we just use CmmStatic +{- Note [Verifying basic blocks]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +   We want to guarantee a few things about the results+   of instruction selection.++   Namely that each basic blocks consists of:+    * A (potentially empty) sequence of straight line instructions+  followed by+    * A (potentially empty) sequence of jump like instructions.++    We can verify this by going through the instructions and+    making sure that any non-jumpish instruction can't appear+    after a jumpish instruction.++    There are gotchas however:+    * CALLs are strictly speaking control flow but here we care+      not about them. Hence we treat them as regular instructions.++      It's safe for them to appear inside a basic block+      as (ignoring side effects inside the call) they will result in+      straight line code.++    * NEWBLOCK marks the start of a new basic block so can+      be followed by any instructions.+-}++-- Verifying basic blocks is cheap, but not cheap enough to enable it unconditionally.+verifyBasicBlock :: [Instr] -> ()+verifyBasicBlock instrs+  | debugIsOn     = go False instrs+  | otherwise     = ()+  where+    go _     [] = ()+    go atEnd (i:instr)+        = case i of+            -- Start a new basic block+            NEWBLOCK {} -> go False instr+            -- Calls are not viable block terminators+            CALL {}     | atEnd -> faultyBlockWith i+                        | not atEnd -> go atEnd instr+            -- All instructions ok, check if we reached the end and continue.+            _ | not atEnd -> go (isJumpishInstr i) instr+              -- Only jumps allowed at the end of basic blocks.+              | otherwise -> if isJumpishInstr i+                                then go True instr+                                else faultyBlockWith i+    faultyBlockWith i+        = pprPanic "Non control flow instructions after end of basic block."+                   (ppr i <+> text "in:" $$ vcat (map ppr instrs))+ basicBlockCodeGen         :: CmmBlock         -> NatM ( [NatBasicBlock Instr]@@ -154,9 +206,10 @@             let line = srcSpanStartLine span; col = srcSpanStartCol span             return $ unitOL $ LOCATION fileId line col name     _ -> return nilOL-  mid_instrs <- stmtsToInstrs id stmts-  tail_instrs <- stmtToInstrs id tail+  (mid_instrs,mid_bid) <- stmtsToInstrs id stmts+  (!tail_instrs,_) <- stmtToInstrs mid_bid tail   let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs+  return $! verifyBasicBlock (fromOL instrs)   instrs' <- fold <$> traverse addSpUnwindings instrs   -- code generation may introduce new basic block boundaries, which   -- are indicated by the NEWBLOCK instruction.  We must split up the@@ -186,60 +239,137 @@         else return (unitOL instr) addSpUnwindings instr = return $ unitOL instr -stmtsToInstrs :: BlockId -> [CmmNode e x] -> NatM InstrBlock-stmtsToInstrs bid stmts-   = do instrss <- mapM (stmtToInstrs bid) stmts-        return (concatOL instrss)+{- Note [Keeping track of the current block]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When generating instructions for Cmm we sometimes require+the current block for things like retry loops.++We also sometimes change the current block, if a MachOP+results in branching control flow.++Issues arise if we have two statements in the same block,+which both depend on the current block id *and* change the+basic block after them. This happens for atomic primops+in the X86 backend where we want to update the CFG data structure+when introducing new basic blocks.++For example in #17334 we got this Cmm code:++        c3Bf: // global+            (_s3t1::I64) = call MO_AtomicRMW W64 AMO_And(_s3sQ::P64 + 88, 18);+            (_s3t4::I64) = call MO_AtomicRMW W64 AMO_Or(_s3sQ::P64 + 88, 0);+            _s3sT::I64 = _s3sV::I64;+            goto c3B1;++This resulted in two new basic blocks being inserted:++        c3Bf:+                movl $18,%vI_n3Bo+                movq 88(%vI_s3sQ),%rax+                jmp _n3Bp+        n3Bp:+                ...+                cmpxchgq %vI_n3Bq,88(%vI_s3sQ)+                jne _n3Bp+                ...+                jmp _n3Bs+        n3Bs:+                ...+                cmpxchgq %vI_n3Bt,88(%vI_s3sQ)+                jne _n3Bs+                ...+                jmp _c3B1+        ...++Based on the Cmm we called stmtToInstrs we translated both atomic operations under+the assumption they would be placed into their Cmm basic block `c3Bf`.+However for the retry loop we introduce new labels, so this is not the case+for the second statement.+This resulted in a desync between the explicit control flow graph+we construct as a separate data type and the actual control flow graph in the code.++Instead we now return the new basic block if a statement causes a change+in the current block and use the block for all following statements.++For this reason genCCall is also split into two parts.+One for calls which *won't* change the basic blocks in+which successive instructions will be placed.+A different one for calls which *are* known to change the+basic block.++-}++-- See Note [Keeping track of the current block] for why+-- we pass the BlockId.+stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.+              -> [CmmNode O O] -- ^ Cmm Statement+              -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction+stmtsToInstrs bid stmts =+    go bid stmts nilOL+  where+    go bid  []        instrs = return (instrs,bid)+    go bid (s:stmts)  instrs = do+      (instrs',bid') <- stmtToInstrs bid s+      -- If the statement introduced a new block, we use that one+      let !newBid = fromMaybe bid bid'+      go newBid stmts (instrs `appOL` instrs')+ -- | `bid` refers to the current block and is used to update the CFG --   if new blocks are inserted in the control flow.-stmtToInstrs :: BlockId -> CmmNode e x -> NatM InstrBlock+-- See Note [Keeping track of the current block] for more details.+stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.+             -> CmmNode e x+             -> NatM (InstrBlock, Maybe BlockId)+             -- ^ Instructions, and bid of new block if successive+             -- statements are placed in a different basic block. stmtToInstrs bid stmt = do   dflags <- getDynFlags   is32Bit <- is32BitPlatform   case stmt of-    CmmComment s   -> return (unitOL (COMMENT s))-    CmmTick {}     -> return nilOL+    CmmUnsafeForeignCall target result_regs args+       -> genCCall dflags is32Bit target result_regs args bid -    CmmUnwind regs -> do-      let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable-          to_unwind_entry (reg, expr) = M.singleton reg (fmap toUnwindExpr expr)-      case foldMap to_unwind_entry regs of-        tbl | M.null tbl -> return nilOL-            | otherwise  -> do-                lbl <- mkAsmTempLabel <$> getUniqueM-                return $ unitOL $ UNWIND lbl tbl+    _ -> (,Nothing) <$> case stmt of+      CmmComment s   -> return (unitOL (COMMENT s))+      CmmTick {}     -> return nilOL -    CmmAssign reg src-      | isFloatType ty         -> assignReg_FltCode format reg src-      | is32Bit && isWord64 ty -> assignReg_I64Code      reg src-      | otherwise              -> assignReg_IntCode format reg src-        where ty = cmmRegType dflags reg-              format = cmmTypeFormat ty+      CmmUnwind regs -> do+        let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable+            to_unwind_entry (reg, expr) = M.singleton reg (fmap toUnwindExpr expr)+        case foldMap to_unwind_entry regs of+          tbl | M.null tbl -> return nilOL+              | otherwise  -> do+                  lbl <- mkAsmTempLabel <$> getUniqueM+                  return $ unitOL $ UNWIND lbl tbl -    CmmStore addr src-      | isFloatType ty         -> assignMem_FltCode format addr src-      | is32Bit && isWord64 ty -> assignMem_I64Code      addr src-      | otherwise              -> assignMem_IntCode format addr src-        where ty = cmmExprType dflags src-              format = cmmTypeFormat ty+      CmmAssign reg src+        | isFloatType ty         -> assignReg_FltCode format reg src+        | is32Bit && isWord64 ty -> assignReg_I64Code      reg src+        | otherwise              -> assignReg_IntCode format reg src+          where ty = cmmRegType dflags reg+                format = cmmTypeFormat ty -    CmmUnsafeForeignCall target result_regs args-       -> genCCall dflags is32Bit target result_regs args bid+      CmmStore addr src+        | isFloatType ty         -> assignMem_FltCode format addr src+        | is32Bit && isWord64 ty -> assignMem_I64Code      addr src+        | otherwise              -> assignMem_IntCode format addr src+          where ty = cmmExprType dflags src+                format = cmmTypeFormat ty -    CmmBranch id          -> return $ genBranch id+      CmmBranch id          -> return $ genBranch id -    --We try to arrange blocks such that the likely branch is the fallthrough-    --in CmmContFlowOpt. So we can assume the condition is likely false here.-    CmmCondBranch arg true false _ -> genCondBranch bid true false arg-    CmmSwitch arg ids -> do dflags <- getDynFlags-                            genSwitch dflags arg ids-    CmmCall { cml_target = arg-            , cml_args_regs = gregs } -> do-                                dflags <- getDynFlags-                                genJump arg (jumpRegs dflags gregs)-    _ ->-      panic "stmtToInstrs: statement should have been cps'd away"+      --We try to arrange blocks such that the likely branch is the fallthrough+      --in CmmContFlowOpt. So we can assume the condition is likely false here.+      CmmCondBranch arg true false _ -> genCondBranch bid true false arg+      CmmSwitch arg ids -> do dflags <- getDynFlags+                              genSwitch dflags arg ids+      CmmCall { cml_target = arg+              , cml_args_regs = gregs } -> do+                                  dflags <- getDynFlags+                                  genJump arg (jumpRegs dflags gregs)+      _ ->+        panic "stmtToInstrs: statement should have been cps'd away"   jumpRegs :: DynFlags -> [GlobalReg] -> [Reg]@@ -1744,6 +1874,109 @@         updateCfgNat (\cfg -> adjustEdgeWeight cfg (+3) bid false)         return (cond_code `appOL` code) +{-  Note [Introducing cfg edges inside basic blocks]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++    During instruction selection a statement `s`+    in a block B with control of the sort: B -> C+    will sometimes result in control+    flow of the sort:++            ┌ < ┐+            v   ^+      B ->  B1  ┴ -> C++    as is the case for some atomic operations.++    Now to keep the CFG in sync when introducing B1 we clearly+    want to insert it between B and C. However there is+    a catch when we have to deal with self loops.++    We might start with code and a CFG of these forms:++    loop:+        stmt1               ┌ < ┐+        ....                v   ^+        stmtX              loop ┘+        stmtY+        ....+        goto loop:++    Now we introduce B1:+                            ┌ ─ ─ ─ ─ ─┐+        loop:               │   ┌ <  ┐ │+        instrs              v   │    │ ^+        ....               loop ┴ B1 ┴ ┘+        instrsFromX+        stmtY+        goto loop:++    This is simple, all outgoing edges from loop now simply+    start from B1 instead and the code generator knows which+    new edges it introduced for the self loop of B1.++    Disaster strikes if the statement Y follows the same pattern.+    If we apply the same rule that all outgoing edges change then+    we end up with:++        loop ─> B1 ─> B2 ┬─┐+          │      │    └─<┤ │+          │      └───<───┘ │+          └───────<────────┘++    This is problematic. The edge B1->B1 is modified as expected.+    However the modification is wrong!++    The assembly in this case looked like this:++    _loop:+        <instrs>+    _B1:+        ...+        cmpxchgq ...+        jne _B1+        <instrs>+        <end _B1>+    _B2:+        ...+        cmpxchgq ...+        jne _B2+        <instrs>+        jmp loop++    There is no edge _B2 -> _B1 here. It's still a self loop onto _B1.++    The problem here is that really B1 should be two basic blocks.+    Otherwise we have control flow in the *middle* of a basic block.+    A contradiction!++    So to account for this we add yet another basic block marker:++    _B:+        <instrs>+    _B1:+        ...+        cmpxchgq ...+        jne _B1+        jmp _B1'+    _B1':+        <instrs>+        <end _B1>+    _B2:+        ...++    Now when inserting B2 we will only look at the outgoing edges of B1' and+    everything will work out nicely.++    You might also wonder why we don't insert jumps at the end of _B1'. There is+    no way another block ends up jumping to the labels _B1 or _B2 since they are+    essentially invisible to other blocks. View them as control flow labels local+    to the basic block if you'd like.++    Not doing this ultimately caused (part 2 of) #17334.+-}++ -- ----------------------------------------------------------------------------- --  Generating C calls @@ -1753,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@@ -1761,13 +1997,180 @@     -> [CmmFormal]        -- where to put the result     -> [CmmActual]        -- arguments (of mixed type)     -> BlockId      -- The block we are in-    -> NatM InstrBlock+    -> NatM (InstrBlock, Maybe BlockId) --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -+-- First we deal with cases which might introduce new blocks in the stream. +genCCall dflags is32Bit (PrimTarget (MO_AtomicRMW width amop))+                                           [dst] [addr, n] bid = do+    Amode amode addr_code <-+        if amop `elem` [AMO_Add, AMO_Sub]+        then getAmode addr+        else getSimpleAmode dflags is32Bit addr  -- See genCCall for MO_Cmpxchg+    arg <- getNewRegNat format+    arg_code <- getAnyReg n+    let platform = targetPlatform dflags+        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+    -- Code for the operation+    op_code :: Reg       -- Destination reg+            -> Reg       -- Register containing argument+            -> AddrMode  -- Address of location to mutate+            -> NatM (OrdList Instr,BlockId) -- TODO: Return Maybe BlockId+    op_code dst_r arg amode = case amop of+        -- In the common case where dst_r is a virtual register the+        -- final move should go away, because it's the last use of arg+        -- and the first use of dst_r.+        AMO_Add  -> return $ (toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode))+                                  , MOV format (OpReg arg) (OpReg dst_r)+                                  ], bid)+        AMO_Sub  -> return $ (toOL [ NEGI format (OpReg arg)+                                  , LOCK (XADD format (OpReg arg) (OpAddr amode))+                                  , MOV format (OpReg arg) (OpReg dst_r)+                                  ], bid)+        -- In these cases we need a new block id, and have to return it so+        -- that later instruction selection can reference it.+        AMO_And  -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst)+        AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst+                                                    , NOT format dst+                                                    ])+        AMO_Or   -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst)+        AMO_Xor  -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst)+      where+        -- Simulate operation that lacks a dedicated instruction using+        -- cmpxchg.+        cmpxchg_code :: (Operand -> Operand -> OrdList Instr)+                     -> NatM (OrdList Instr, BlockId)+        cmpxchg_code instrs = do+            lbl1 <- getBlockIdNat+            lbl2 <- getBlockIdNat+            tmp <- getNewRegNat format++            --Record inserted blocks+            --  We turn A -> B into A -> A' -> A'' -> B+            --  with a self loop on A'.+            addImmediateSuccessorNat bid lbl1+            addImmediateSuccessorNat lbl1 lbl2+            updateCfgNat (addWeightEdge lbl1 lbl1 0)++            return $ (toOL+                [ MOV format (OpAddr amode) (OpReg eax)+                , JXX ALWAYS lbl1+                , NEWBLOCK lbl1+                  -- Keep old value so we can return it:+                , MOV format (OpReg eax) (OpReg dst_r)+                , MOV format (OpReg eax) (OpReg tmp)+                ]+                `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL+                [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode))+                , JXX NE lbl1+                -- See Note [Introducing cfg edges inside basic blocks]+                -- why this basic block is required.+                , JXX ALWAYS lbl2+                , NEWBLOCK lbl2+                ],+                lbl2)+    format = intFormat width++genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid+  | is32Bit, width == W64 = do+      ChildCode64 vcode rlo <- iselExpr64 src+      let rhi     = getHiVRegFromLo rlo+          dst_r   = getRegisterReg platform  (CmmLocal dst)+      lbl1 <- getBlockIdNat+      lbl2 <- getBlockIdNat+      let format = if width == W8 then II16 else intFormat width+      tmp_r <- getNewRegNat format++      -- New CFG Edges:+      --  bid -> lbl2+      --  bid -> lbl1 -> lbl2+      --  We also changes edges originating at bid to start at lbl2 instead.+      updateCfgNat (addWeightEdge bid lbl1 110 .+                    addWeightEdge lbl1 lbl2 110 .+                    addImmediateSuccessor bid lbl2)++      -- The following instruction sequence corresponds to the pseudo-code+      --+      --  if (src) {+      --    dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32);+      --  } else {+      --    dst = 64;+      --  }+      let !instrs = vcode `appOL` toOL+               ([ MOV      II32 (OpReg rhi)         (OpReg tmp_r)+                , OR       II32 (OpReg rlo)         (OpReg tmp_r)+                , MOV      II32 (OpImm (ImmInt 64)) (OpReg dst_r)+                , JXX EQQ    lbl2+                , JXX ALWAYS lbl1++                , NEWBLOCK   lbl1+                , BSF     II32 (OpReg rhi)         dst_r+                , ADD     II32 (OpImm (ImmInt 32)) (OpReg dst_r)+                , BSF     II32 (OpReg rlo)         tmp_r+                , CMOV NE II32 (OpReg tmp_r)       dst_r+                , JXX ALWAYS lbl2++                , NEWBLOCK   lbl2+                ])+      return (instrs, Just lbl2)++  | otherwise = do+    code_src <- getAnyReg src+    let dst_r = getRegisterReg platform (CmmLocal dst)++    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++genCCall dflags bits mop dst args bid = do+  instr <- genCCall' dflags bits mop dst args bid+  return (instr, Nothing)++-- genCCall' handles cases not introducing new code blocks.+genCCall'+    :: DynFlags+    -> Bool                     -- 32 bit platform?+    -> ForeignTarget            -- function to call+    -> [CmmFormal]        -- where to put the result+    -> [CmmActual]        -- arguments (of mixed type)+    -> BlockId      -- The block we are in+    -> NatM InstrBlock+ -- Unroll memcpy calls if the number of bytes to copy isn't too -- large.  Otherwise, call C's memcpy.-genCCall dflags _ (PrimTarget (MO_Memcpy align)) _+genCCall' dflags _ (PrimTarget (MO_Memcpy align)) _          [dst, src, CmmLit (CmmInt n _)] _     | fromInteger insns <= maxInlineMemcpyInsns dflags = do         code_dst <- getAnyReg dst@@ -1816,7 +2219,7 @@         dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone                    (ImmInteger (n - i)) -genCCall dflags _ (PrimTarget (MO_Memset align)) _+genCCall' dflags _ (PrimTarget (MO_Memset align)) _          [dst,           CmmLit (CmmInt c _),           CmmLit (CmmInt n _)]@@ -1889,14 +2292,14 @@         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+genCCall' _ _ (PrimTarget MO_ReadBarrier) _ _ _  = return nilOL+genCCall' _ _ (PrimTarget MO_WriteBarrier) _ _ _ = return nilOL         -- barriers compile to no code on x86/x86-64;         -- we keep it this long in order to prevent earlier optimisations. -genCCall _ _ (PrimTarget MO_Touch) _ _ _ = return nilOL+genCCall' _ _ (PrimTarget MO_Touch) _ _ _ = return nilOL -genCCall _ is32bit (PrimTarget (MO_Prefetch_Data n )) _  [src] _ =+genCCall' _ is32bit (PrimTarget (MO_Prefetch_Data n )) _  [src] _ =         case n of             0 -> genPrefetch src $ PREFETCH NTA  format             1 -> genPrefetch src $ PREFETCH Lvl2 format@@ -1917,7 +2320,7 @@                               ((AddrBaseIndex (EABaseReg src_r )   EAIndexNone (ImmInt 0))))  ))                   -- prefetch always takes an address -genCCall dflags is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] _ = do+genCCall' dflags is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] _ = do     let platform = targetPlatform dflags     let dst_r = getRegisterReg platform (CmmLocal dst)     case width of@@ -1939,7 +2342,7 @@   where     format = intFormat width -genCCall dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]+genCCall' dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]          args@[src] bid = do     sse4_2 <- sse4_2Enabled     let platform = targetPlatform dflags@@ -1965,12 +2368,12 @@             let target = ForeignTarget targetExpr (ForeignConvention CCallConv                                                            [NoHint] [NoHint]                                                            CmmMayReturn)-            genCCall dflags is32Bit target dest_regs args bid+            genCCall' dflags is32Bit target dest_regs args bid   where     format = intFormat width     lbl = mkCmmCodeLabel primUnitId (fsLit (popCntLabel width)) -genCCall dflags is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst]+genCCall' dflags is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst]          args@[src, mask] bid = do     let platform = targetPlatform dflags     if isBmi2Enabled dflags@@ -1998,12 +2401,12 @@             let target = ForeignTarget targetExpr (ForeignConvention CCallConv                                                            [NoHint] [NoHint]                                                            CmmMayReturn)-            genCCall dflags is32Bit target dest_regs args bid+            genCCall' dflags is32Bit target dest_regs args bid   where     format = intFormat width     lbl = mkCmmCodeLabel primUnitId (fsLit (pdepLabel width)) -genCCall dflags is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst]+genCCall' dflags is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst]          args@[src, mask] bid = do     let platform = targetPlatform dflags     if isBmi2Enabled dflags@@ -2031,19 +2434,19 @@             let target = ForeignTarget targetExpr (ForeignConvention CCallConv                                                            [NoHint] [NoHint]                                                            CmmMayReturn)-            genCCall dflags is32Bit target dest_regs args bid+            genCCall' dflags is32Bit target dest_regs args bid   where     format = intFormat width     lbl = mkCmmCodeLabel primUnitId (fsLit (pextLabel width)) -genCCall dflags is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] bid+genCCall' dflags is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] bid   | is32Bit && width == W64 = do     -- Fallback to `hs_clz64` on i386     targetExpr <- cmmMakeDynamicReference dflags CallReference lbl     let target = ForeignTarget targetExpr (ForeignConvention CCallConv                                            [NoHint] [NoHint]                                            CmmMayReturn)-    genCCall dflags is32Bit target dest_regs args bid+    genCCall' dflags is32Bit target dest_regs args bid    | otherwise = do     code_src <- getAnyReg src@@ -2080,167 +2483,27 @@     platform = targetPlatform dflags     lbl = mkCmmCodeLabel primUnitId (fsLit (clzLabel width)) -genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid-  | is32Bit, width == W64 = do-      ChildCode64 vcode rlo <- iselExpr64 src-      let rhi     = getHiVRegFromLo rlo-          dst_r   = getRegisterReg platform  (CmmLocal dst)-      lbl1 <- getBlockIdNat-      lbl2 <- getBlockIdNat-      let format = if width == W8 then II16 else intFormat width-      tmp_r <- getNewRegNat format--      -- New CFG Edges:-      --  bid -> lbl2-      --  bid -> lbl1 -> lbl2-      --  We also changes edges originating at bid to start at lbl2 instead.-      updateCfgNat (addWeightEdge bid lbl1 110 .-                    addWeightEdge lbl1 lbl2 110 .-                    addImmediateSuccessor bid lbl2)--      -- The following instruction sequence corresponds to the pseudo-code-      ---      --  if (src) {-      --    dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32);-      --  } else {-      --    dst = 64;-      --  }-      return $ vcode `appOL` toOL-               ([ MOV      II32 (OpReg rhi)         (OpReg tmp_r)-                , OR       II32 (OpReg rlo)         (OpReg tmp_r)-                , MOV      II32 (OpImm (ImmInt 64)) (OpReg dst_r)-                , JXX EQQ    lbl2-                , JXX ALWAYS lbl1--                , NEWBLOCK   lbl1-                , BSF     II32 (OpReg rhi)         dst_r-                , ADD     II32 (OpImm (ImmInt 32)) (OpReg dst_r)-                , BSF     II32 (OpReg rlo)         tmp_r-                , CMOV NE II32 (OpReg tmp_r)       dst_r-                , JXX ALWAYS lbl2--                , NEWBLOCK   lbl2-                ])--  | otherwise = do-    code_src <- getAnyReg src-    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-                [ 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-    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-        return $ code_src src_r `appOL` toOL-                 ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] ++-                  [ BSF     format (OpReg src_r) tmp_r-                  , MOV     II32   (OpImm (ImmInt bw)) (OpReg dst_r)-                  , CMOV NE format (OpReg tmp_r) dst_r-                  ]) -- NB: We don't need to zero-extend the result for the-                     -- W8/W16 cases because the 'MOV' insn already-                     -- took care of implicitly clearing the upper bits-  where-    bw = widthInBits width-    platform = targetPlatform dflags--genCCall dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do+genCCall' dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do     targetExpr <- cmmMakeDynamicReference dflags                   CallReference lbl     let target = ForeignTarget targetExpr (ForeignConvention CCallConv                                            [NoHint] [NoHint]                                            CmmMayReturn)-    genCCall dflags is32Bit target dest_regs args bid+    genCCall' dflags is32Bit target dest_regs args bid   where     lbl = mkCmmCodeLabel primUnitId (fsLit (word2FloatLabel width)) -genCCall dflags is32Bit (PrimTarget (MO_AtomicRMW width amop))-                                           [dst] [addr, n] bid = do-    Amode amode addr_code <--        if amop `elem` [AMO_Add, AMO_Sub]-        then getAmode addr-        else getSimpleAmode dflags is32Bit addr  -- See genCCall for MO_Cmpxchg-    arg <- getNewRegNat format-    arg_code <- getAnyReg n-    let platform = targetPlatform dflags-        dst_r    = getRegisterReg platform  (CmmLocal dst)-    code <- op_code dst_r arg amode-    return $ addr_code `appOL` arg_code arg `appOL` code-  where-    -- Code for the operation-    op_code :: Reg       -- Destination reg-            -> Reg       -- Register containing argument-            -> AddrMode  -- Address of location to mutate-            -> NatM (OrdList Instr)-    op_code dst_r arg amode = case amop of-        -- In the common case where dst_r is a virtual register the-        -- final move should go away, because it's the last use of arg-        -- and the first use of dst_r.-        AMO_Add  -> return $ toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode))-                                  , MOV format (OpReg arg) (OpReg dst_r)-                                  ]-        AMO_Sub  -> return $ toOL [ NEGI format (OpReg arg)-                                  , LOCK (XADD format (OpReg arg) (OpAddr amode))-                                  , MOV format (OpReg arg) (OpReg dst_r)-                                  ]-        AMO_And  -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst)-        AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst-                                                    , NOT format dst-                                                    ])-        AMO_Or   -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst)-        AMO_Xor  -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst)-      where-        -- Simulate operation that lacks a dedicated instruction using-        -- cmpxchg.-        cmpxchg_code :: (Operand -> Operand -> OrdList Instr)-                     -> NatM (OrdList Instr)-        cmpxchg_code instrs = do-            lbl <- getBlockIdNat-            tmp <- getNewRegNat format--            --Record inserted blocks-            addImmediateSuccessorNat bid lbl-            updateCfgNat (addWeightEdge lbl lbl 0)--            return $ toOL-                [ MOV format (OpAddr amode) (OpReg eax)-                , JXX ALWAYS lbl-                , NEWBLOCK lbl-                  -- Keep old value so we can return it:-                , MOV format (OpReg eax) (OpReg dst_r)-                , MOV format (OpReg eax) (OpReg tmp)-                ]-                `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL-                [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode))-                , JXX NE lbl-                ]--    format = intFormat width--genCCall dflags _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] _ = do+genCCall' dflags _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] _ = do   load_code <- intLoadCode (MOV (intFormat width)) addr   let platform = targetPlatform dflags    return (load_code (getRegisterReg platform  (CmmLocal dst))) -genCCall _ _ (PrimTarget (MO_AtomicWrite width)) [] [addr, val] _ = do+genCCall' _ _ (PrimTarget (MO_AtomicWrite width)) [] [addr, val] _ = do     code <- assignMem_IntCode (intFormat width) addr val     return $ code `snocOL` MFENCE -genCCall dflags is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] _ = do+genCCall' dflags is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] _ = do     -- On x86 we don't have enough registers to use cmpxchg with a     -- complicated addressing mode, so on that architecture we     -- pre-compute the address first.@@ -2261,7 +2524,7 @@   where     format = intFormat width -genCCall _ is32Bit target dest_regs args bid = do+genCCall' _ is32Bit target dest_regs args bid = do   dflags <- getDynFlags   let platform = targetPlatform dflags   case (target, dest_regs) of@@ -2860,7 +3123,10 @@       let target = ForeignTarget targetExpr                            (ForeignConvention CCallConv [] [] CmmMayReturn) -      stmtToInstrs bid (CmmUnsafeForeignCall target (catMaybes [res]) args)+      -- 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         -- Assume we can call these functions directly, and that they're not in a dynamic library.         -- TODO: Why is this ok? Under linux this code will be in libm.so@@ -3400,10 +3666,14 @@ -- | This works on the invariant that all jumps in the given blocks are required. --   Starting from there we try to make a few more jumps redundant by reordering --   them.-invertCondBranches :: CFG -> LabelMap a -> [NatBasicBlock Instr]+--   We depend on the information in the CFG to do so so without a given CFG+--   we do nothing.+invertCondBranches :: Maybe CFG  -- ^ CFG if present+                   -> LabelMap a -- ^ Blocks with info tables+                   -> [NatBasicBlock Instr] -- ^ List of basic blocks                    -> [NatBasicBlock Instr]-invertCondBranches cfg keep bs =-    --trace "Foo" $+invertCondBranches Nothing _       bs = bs+invertCondBranches (Just cfg) keep bs =     invert bs   where     invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr]@@ -3422,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
@@ -292,7 +292,9 @@                       [Maybe JumpDest] -- Targets of the jump table                       Section   -- Data section jump table should be put in                       CLabel    -- Label of jump table-        | CALL        (Either Imm Reg) [Reg]+        -- | X86 call instruction+        | CALL        (Either Imm Reg) -- ^ Jump target+                      [Reg]            -- ^ Arguments (required for register allocation)          -- Other things.         | CLTD Format            -- sign extend %eax into %edx:%eax
compiler/rename/RnBinds.hs view
@@ -49,7 +49,7 @@ import RdrName          ( RdrName, rdrNameOcc ) import SrcLoc import ListSetOps       ( findDupsEq )-import BasicTypes       ( RecFlag(..) )+import BasicTypes       ( RecFlag(..), TypeOrKind(..) ) import Digraph          ( SCC(..) ) import Bag import Util
compiler/rename/RnEnv.hs view
@@ -1266,10 +1266,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  {-
compiler/rename/RnExpr.hs view
@@ -108,11 +108,7 @@         then -- Treat this as a "hole"              -- Do not fail right now; instead, return HsUnboundVar              -- and let the type checker report the error-             do { let occ = rdrNameOcc v-                ; uv <- if startsWithUnderscore occ-                        then return (TrueExprHole occ)-                        else OutOfScope occ <$> getGlobalRdrEnv-                ; return (HsUnboundVar noExtField uv, emptyFVs) }+             return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs)          else -- Fail immediately (qualified name)              do { n <- reportUnboundName v@@ -121,11 +117,14 @@ 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+                                       -- Note [Empty lists] in GHC.Hs.Expr+              , xopt LangExt.OverloadedLists dflags               -> rnExpr (ExplicitList noExtField Nothing [])                | otherwise@@ -208,8 +207,6 @@  ------------------------------------------ -- Template Haskell extensions--- Don't ifdef-HAVE_INTERPRETER 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
compiler/rename/RnFixity.hs view
@@ -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
compiler/rename/RnNames.hs view
@@ -393,8 +393,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@@ -1190,16 +1190,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 @@ -1207,13 +1207,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 @@ -1228,8 +1221,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)
compiler/rename/RnSource.hs view
@@ -52,7 +52,7 @@ import Avail import Outputable import Bag-import BasicTypes       ( pprRuleName )+import BasicTypes       ( pprRuleName, TypeOrKind(..) ) import FastString import SrcLoc import DynFlags@@ -1141,7 +1141,7 @@     text "LHS must be of form (f e1 .. en) where f is not forall'd"   where     err = case bad_e of-            HsUnboundVar _ uv -> notInScopeErr (mkRdrUnqual (unboundVarOcc uv))+            HsUnboundVar _ uv -> notInScopeErr (mkRdrUnqual uv)             _                 -> text "Illegal expression:" <+> ppr bad_e  {- **************************************************************
compiler/rename/RnTypes.hs view
@@ -57,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@@ -1180,7 +1181,7 @@ -- | Name of an operator in an operator application or section data OpName = NormalOp Name         -- ^ A normal identifier             | NegateOp              -- ^ Prefix negation-            | UnboundOp UnboundVar  -- ^ An unbound indentifier+            | UnboundOp OccName     -- ^ An unbound indentifier             | RecFldOp (AmbiguousFieldOcc GhcRn)               -- ^ A (possibly ambiguous) record field occurrence @@ -1347,7 +1348,7 @@ lookupFixityOp :: OpName -> RnM Fixity lookupFixityOp (NormalOp n)  = lookupFixityRn n lookupFixityOp NegateOp      = lookupFixityRn negateName-lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName (unboundVarOcc u))+lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName u) lookupFixityOp (RecFldOp f)  = lookupFieldFixityRn f
compiler/simplCore/SimplCore.hs view
@@ -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@@ -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(HAVE_INTERPRETER) 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/simplStg/SimplStg.hs view
@@ -48,22 +48,23 @@         -> IO [StgTopBinding]        -- output program  stg2stg dflags this_mod binds-  = do  { showPass dflags "Stg2Stg"+  = do  { dump_when Opt_D_dump_stg "STG:" binds+        ; showPass dflags "Stg2Stg"         ; us <- mkSplitUniqSupply 'g'          -- Do the main business!         ; binds' <- runStgM us $             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/specialise/Specialise.hs view
@@ -16,6 +16,7 @@ import Id import TcType hiding( substTy ) import Type   hiding( substTy, extendTvSubstList )+import Predicate import Module( Module, HasModule(..) ) import Coercion( Coercion ) import CoreMonad
compiler/stranal/DmdAnal.hs view
@@ -333,10 +333,7 @@   | (bndr:_) <- bndrs   , con == tupleDataCon Unboxed 2   , idType bndr `eqType` realWorldStatePrimTy-  , (fun, _) <- collectArgs scrut-  = case fun of-      Var f -> not (isPrimOpId f)-      _     -> True+  = not (exprOkForSpeculation scrut)   | otherwise   = False @@ -387,15 +384,18 @@ situation actually arises in GHC.IO.Handle.Internals.wantReadableHandle (on an MVar not an Int), and made a material difference. -So if the scrutinee is a primop call, we *don't* apply the-state hack:+So if the scrutinee is ok-for-speculation, we *don't* apply the state hack,+because we are free to push evaluation of the scrutinee after evaluation of+expressions from the (single) case alternative.++A few examples for different scrutinees:   - If it is a simple, terminating one like getMaskingState,-    applying the hack is over-conservative.-  - If the primop is raise# then it returns bottom, so-    the case alternatives are already discarded.+    applying the hack would be over-conservative.+  - If the primop is raise# then it returns bottom (so not ok-for-speculation),+    but the result from the case alternatives are discarded anyway.   - If the primop can raise a non-IO exception, like-    divide by zero or seg-fault (eg writing an array-    out of bounds) then we don't mind evaluating 'x' first.+    divide by zero (so not ok-for-speculation), then we are also bottoming out+    anyway and don't mind evaluating 'x' first.  Note [Demand on the scrutinee of a product case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/stranal/WwLib.hs view
@@ -30,6 +30,7 @@ import VarEnv           ( mkInScopeSet ) import VarSet           ( VarSet ) import Type+import Predicate        ( isClassPred ) import RepType          ( isVoidTy, typePrimRep ) import Coercion import FamInstEnv
compiler/typecheck/ClsInst.hs view
@@ -3,7 +3,7 @@ module ClsInst (      matchGlobalInst,      ClsInstResult(..),-     InstanceWhat(..), safeOverlap,+     InstanceWhat(..), safeOverlap, instanceReturnsDictCon,      AssocInstInfo(..), isNotAssociated   ) where @@ -14,9 +14,10 @@ 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]@@ -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)
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+        makeInjectivityErrors     ) where  import GhcPrelude@@ -36,14 +36,17 @@ import Maybes import Type import TyCoRep+import TyCoFVs import TcMType import Name-import Pair import Panic import VarSet+import FV import Bag( Bag, unionBags, unitBag ) import Control.Monad +import qualified GHC.LanguageExtensions  as LangExt+ #include "HsVersions.h"  {- Note [The type family instance consistency story]@@ -319,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 @@ -719,10 +722,11 @@     | isTypeFamilyTyCon tycon     -- type family is injective in at least one argument     , Injective inj <- tyConInjectivityInfo tycon = do-    { let axiom = coAxiomSingleBranch fi_ax+    { dflags <- getDynFlags+    ; let axiom = coAxiomSingleBranch fi_ax           conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst           -- see Note [Verifying injectivity annotation] in FamInstEnv-          errs = makeInjectivityErrors fi_ax axiom inj conflicts+          errs = makeInjectivityErrors dflags fi_ax axiom inj conflicts     ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err) errs     ; return (null errs)     }@@ -735,19 +739,21 @@  -- | Build a list of injectivity errors together with their source locations. makeInjectivityErrors-   :: CoAxiom br   -- ^ Type family for which we generate errors+   :: 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+makeInjectivityErrors dflags fi_ax axiom inj conflicts   = 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)+        (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@@ -758,81 +764,11 @@                           , 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 inj_tvs_unused (unusedInjectiveVarsErr unused_inj_tvs+                                     unused_vis undec_inst_flag)         ++ 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] in FamInstEnv.--- This function implements check (4) 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"--injTyVarsOfTypes :: [Type] -> VarSet-injTyVarsOfTypes tys = mapUnionVarSet injTyVarsOfType tys- -- | Is type headed by a type family application? isTFHeaded :: Type -> Bool -- See Note [Verifying injectivity annotation], case 3.@@ -852,7 +788,164 @@    = filter (not . isTyVarTy) pats bareTvInRHSViolated _ _ = [] +------------------------------------------------------------------+-- Checking for the coverage condition for injective type families+------------------------------------------------------------------ +{-+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:++  type family F a b = r | r -> a      -- NB: b is not injective++  type instance F ty1 ty2 = ty3++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+      undec_inst = xopt LangExt.UndecidableInstances dflags++      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+---------------------------------------+ -- | 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)@@ -883,26 +976,28 @@   = panic "conflictInjInstErr"  -- | Build error message for equation with injective type variables unused in--- the RHS.-unusedInjectiveVarsErr :: Pair TyVarSet -> InjErrorBuilder -> CoAxBranch+-- the RHS. Note [Coverage condition for injective type families], step 6+unusedInjectiveVarsErr :: TyVarSet+                       -> Bool   -- True <=> print invisible arguments+                       -> Bool   -- True <=> suggest -XUndecidableInstances+                       -> InjErrorBuilder -> CoAxBranch                        -> (SDoc, SrcSpan)-unusedInjectiveVarsErr (Pair invis_vars vis_vars) errorBuilder tyfamEqn+unusedInjectiveVarsErr tvs has_kinds undec_inst errorBuilder tyfamEqn   = let (doc, loc) = errorBuilder (injectivityErrorHerald True $$ msg)                                   [tyfamEqn]     in (pprWithExplicitKindsWhen has_kinds doc, loc)     where-      tvs = invis_vars `unionVarSet` vis_vars-      has_types = not $ isEmptyVarSet vis_vars-      has_kinds = not $ isEmptyVarSet invis_vars-       doc = 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+            $$ extra++      what | has_kinds = text "Type/kind"+           | otherwise = text "Type"++      extra | undec_inst = text "Using UndecidableInstances might help"+            | otherwise  = empty+       msg = doc $$ text "In the type family equation:"  -- | Build error message for equation that has a type family call at the top
compiler/typecheck/FunDeps.hs view
@@ -24,14 +24,16 @@ 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 FV import Outputable import ErrUtils( Validity(..), allValid ) import SrcLoc@@ -549,7 +551,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
compiler/typecheck/Inst.hs view
@@ -42,6 +42,9 @@ import GHC.Hs import TcHsSyn import TcRnMonad+import Constraint+import Predicate+import TcOrigin import TcEnv import TcEvidence import InstEnv@@ -66,6 +69,7 @@ import DynFlags import Util import Outputable+import BasicTypes ( TypeOrKind(..) ) import qualified GHC.LanguageExtensions as LangExt  import Control.Monad( unless )
compiler/typecheck/TcArrows.hs view
@@ -16,7 +16,7 @@  import GHC.Hs import TcMatches-import TcHsSyn( hsLPatType )+import TcHsSyn( hsPatType ) import TcType import TcMType import TcBinds@@ -24,6 +24,7 @@ import TcUnify import TcRnMonad import TcEnv+import TcOrigin import TcEvidence import Id( mkLocalId ) import Inst@@ -257,7 +258,7 @@         ; let match' = L mtch_loc (Match { m_ext = noExtField                                          , m_ctxt = LambdaExpr, m_pats = pats'                                          , m_grhss = grhss' })-              arg_tys = map hsLPatType pats'+              arg_tys = map hsPatType pats'               cmd' = HsCmdLam x (MG { mg_alts = L l [match']                                     , mg_ext = MatchGroupTc arg_tys res_ty                                     , mg_origin = origin })
compiler/typecheck/TcBackpack.hs view
@@ -19,7 +19,7 @@  import GhcPrelude -import BasicTypes (defaultFixity)+import BasicTypes (defaultFixity, TypeOrKind(..)) import Packages import TcRnExports import DynFlags@@ -34,6 +34,8 @@ import TcMType import TcType import TcSimplify+import Constraint+import TcOrigin import LoadIface import RnNames import ErrUtils@@ -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 $@@ -521,7 +523,6 @@         -- tcg_dus?         -- tcg_th_used           = tcg_th_used orig_tcg_env,         -- tcg_th_splice_used    = tcg_th_splice_used orig_tcg_env-        -- tcg_th_top_level_locs = tcg_th_top_level_locs orig_tcg_env        }) $ do     tcg_env <- getGblEnv @@ -832,7 +833,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 +844,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 +879,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 @@ -26,9 +25,9 @@ import DynFlags import FastString import GHC.Hs-import HscTypes( isHsBootOrSig ) import TcSigs import TcRnMonad+import TcOrigin import TcEnv import TcUnify import TcSimplify@@ -70,21 +69,6 @@ import Data.Foldable (find)  #include "HsVersions.h"--{- *********************************************************************-*                                                                      *-               A useful helper function-*                                                                      *-********************************************************************* -}--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 }  {- ************************************************************************
compiler/typecheck/TcCanonical.hs view
@@ -13,7 +13,9 @@  import GhcPrelude -import TcRnTypes+import Constraint+import Predicate+import TcOrigin import TcUnify( swapOverTyVars, metaTyVarUpdateOK ) import TcType import Type@@ -32,6 +34,7 @@ import Var import VarEnv( mkInScopeSet ) import VarSet( delVarSetList )+import OccName ( OccName ) import Outputable import DynFlags( DynFlags ) import NameSet@@ -48,6 +51,7 @@ import BasicTypes  import Data.Bifunctor ( bimap )+import Data.Foldable ( traverse_ )  {- ************************************************************************@@ -133,8 +137,8 @@   = {-# SCC "canEqLeafFunEq" #-}     canCFunEqCan ev fn xis1 fsk -canonicalize (CHoleCan { cc_ev = ev, cc_hole = hole })-  = canHole ev hole+canonicalize (CHoleCan { cc_ev = ev, cc_occ = occ, cc_hole = hole })+  = canHole ev occ hole  {- ************************************************************************@@ -282,7 +286,7 @@    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.@@ -615,7 +619,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.   ************************************************************************@@ -639,13 +643,14 @@            _                     -> continueWith $                                     mkIrredCt new_ev } } -canHole :: CtEvidence -> Hole -> TcS (StopOrContinue Ct)-canHole ev hole+canHole :: CtEvidence -> OccName -> HoleSort -> TcS (StopOrContinue Ct)+canHole ev occ hole_sort   = do { let pred = ctEvPred ev        ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred        ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->     do { updInertIrreds (`snocCts` (CHoleCan { cc_ev = new_ev-                                             , cc_hole = hole }))+                                             , cc_occ = occ+                                             , cc_hole = hole_sort }))        ; stopWith new_ev "Emit insoluble hole" } }  @@ -699,7 +704,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 @@ -1267,13 +1272,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.@@ -1288,10 +1302,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@@ -1309,7 +1323,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@@ -1321,6 +1335,8 @@        ; canEqNC evar_s NomEq s1 s2 }    where+    loc = ctEvLoc ev+     s1k = tcTypeKind s1     s2k = tcTypeKind s2 @@ -1571,6 +1587,7 @@ Conclusion:   * Decompose [W] N s ~R N t  iff there no given constraint that could     later solve it.+ -}  canDecomposableTyConAppOK :: CtEvidence -> EqRel@@ -1834,9 +1851,9 @@            -> 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    -- So the LHS and RHS don't have equal kinds   -- Note [Flattening] in TcFlatten gives us (F2), which says that@@ -1875,7 +1892,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@@ -1891,7 +1908,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@@ -1955,16 +1972,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@@ -1984,11 +2001,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)@@ -1997,7 +2014,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@@ -2102,7 +2119,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@@ -2172,7 +2189,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.  -}
compiler/typecheck/TcClassDcl.hs view
@@ -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(..))
compiler/typecheck/TcDeriv.hs view
@@ -20,6 +20,8 @@  import TcRnMonad import FamInst+import TcOrigin+import Predicate import TcDerivInfer import TcDerivUtils import TcValidity( allDistinctTyVars )@@ -60,7 +62,6 @@ import Outputable import FastString import Bag-import Pair import FV (fvVarList, unionFV, mkFVs) import qualified GHC.LanguageExtensions as LangExt @@ -99,10 +100,6 @@         --                  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 [] = ([],[])@@ -157,31 +154,6 @@ And then translate it to:     instance C [a] Char => C [a] T where ... --Note [Newtype deriving superclasses]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-(See also #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 #3221.  Consider@@ -216,13 +188,10 @@ 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)+    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@@ -260,8 +229,7 @@         ; 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+        ; (inst_info, rn_binds, rn_dus) <- renameDeriv inst_infos binds          ; unless (isEmptyBag inst_info) $              liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"@@ -297,19 +265,10 @@       equals <+> ppr rhs   where rhs = famInstRHS fi -renameDeriv :: Bool-            -> [InstInfo GhcPs]+renameDeriv :: [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+renameDeriv inst_infos bagBinds   = discardWarnings $     -- Discard warnings about unused bindings etc     setXOptM LangExt.EmptyCase $@@ -362,25 +321,6 @@               ; return (inst_info { iBinds = binds' }, fvs) }  {--Note [Newtype deriving and unused constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (see #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 #2721):@@ -489,11 +429,10 @@ @makeDerivSpecs@ fishes around to find the info about needed derived instances. -} -makeDerivSpecs :: Bool-               -> [DerivInfo]+makeDerivSpecs :: [DerivInfo]                -> [LDerivDecl GhcRn]                -> TcM [EarlyDerivSpec]-makeDerivSpecs is_boot deriv_infos deriv_decls+makeDerivSpecs deriv_infos deriv_decls   = do  { eqns1 <- sequenceA                      [ deriveClause rep_tc scoped_tvs dcs preds err_ctxt                      | DerivInfo { di_rep_tc = rep_tc@@ -505,17 +444,7 @@                          <- clauses                      ]         ; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls-        ; let eqns = concat eqns1 ++ catMaybes 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"))+        ; return $ concat eqns1 ++ catMaybes eqns2 }  ------------------------------------------------------------------ -- | Process the derived classes in a single @deriving@ clause.@@ -690,7 +619,7 @@   = setSrcSpan loc                   $     addErrCtxt (standaloneCtxt deriv_ty)  $     do { traceTc "Standalone deriving decl for" (ppr deriv_ty)-       ; let ctxt = TcType.InstDeclCtxt True+       ; 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@@ -1336,27 +1265,20 @@ 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 StockStrategy    -> mk_eqn_stock+         Just AnyclassStrategy -> mk_eqn_anyclass          Just (ViaStrategy ty) -> mk_eqn_via ty          -- GeneralizedNewtypeDeriving makes no sense for non-newtypes-         Just NewtypeStrategy  -> bale_out gndNonNewtypeErr+         Just NewtypeStrategy  -> derivingThingFailWith False 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+         Nothing               -> mk_eqn_no_mechanism --- 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+-- 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_tc           = tc@@ -1369,7 +1291,7 @@            inst_tys = cls_tys ++ [inst_ty]        doDerivInstErrorChecks1 mechanism        loc       <- lift getSrcSpanM-       dfun_name <- lift $ newDFunName' cls tc+       dfun_name <- lift $ newDFunName cls inst_tys loc        case deriv_ctxt of         InferContext wildcard ->           do { (inferred_constraints, tvs', inst_tys')@@ -1395,155 +1317,8 @@                    , 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-                               -- (#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+mk_eqn_stock :: DerivM EarlyDerivSpec+mk_eqn_stock   = do DerivEnv { denv_tc      = tc                 , denv_rep_tc  = rep_tc                 , denv_cls     = cls@@ -1552,31 +1327,27 @@        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)+         CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ DerivSpecStock gen_fn+         StockClassError msg   -> derivingThingFailWith False msg+         _                     -> derivingThingFailWith False (nonStdErr cls) -mk_eqn_anyclass :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)-                -> (SDoc -> DerivM EarlyDerivSpec)-                -> DerivM EarlyDerivSpec-mk_eqn_anyclass go_for_it bale_out+mk_eqn_anyclass :: DerivM EarlyDerivSpec+mk_eqn_anyclass   = do dflags <- getDynFlags        case canDeriveAnyClass dflags of-         IsValid      -> go_for_it DerivSpecAnyClass-         NotValid msg -> bale_out msg+         IsValid      -> mk_eqn_from_mechanism DerivSpecAnyClass+         NotValid msg -> derivingThingFailWith False msg  mk_eqn_newtype :: Type -- The newtype's representation type                -> DerivM EarlyDerivSpec-mk_eqn_newtype = mk_coerce_based_eqn DerivSpecNewtype+mk_eqn_newtype rep_ty = mk_eqn_from_mechanism (DerivSpecNewtype rep_ty)  mk_eqn_via :: Type -- The @via@ type            -> DerivM EarlyDerivSpec-mk_eqn_via = mk_coerce_based_eqn DerivSpecVia+mk_eqn_via via_ty = mk_eqn_from_mechanism (DerivSpecVia via_ty) -mk_eqn_no_mechanism :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)-                    -> (SDoc -> DerivM EarlyDerivSpec)-                    -> DerivM EarlyDerivSpec-mk_eqn_no_mechanism go_for_it bale_out+mk_eqn_no_mechanism :: DerivM EarlyDerivSpec+mk_eqn_no_mechanism   = do DerivEnv { denv_tc      = tc                 , denv_rep_tc  = rep_tc                 , denv_cls     = cls@@ -1597,10 +1368,10 @@                                            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+           NonDerivableClass   msg -> derivingThingFailWith False (dac_error msg)+           StockClassError msg     -> derivingThingFailWith False msg+           CanDeriveStock gen_fn   -> mk_eqn_from_mechanism $ DerivSpecStock gen_fn+           CanDeriveAnyClass       -> mk_eqn_from_mechanism DerivSpecAnyClass  {- ************************************************************************@@ -1625,10 +1396,9 @@         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 +           bale_out = derivingThingFailWith newtype_deriving+            non_std     = nonStdErr cls            suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's"                      <+> text "newtype-deriving extension"@@ -1705,8 +1475,8 @@         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 StockStrategy    -> mk_eqn_stock+         Just AnyclassStrategy -> mk_eqn_anyclass          Just NewtypeStrategy  ->            -- Since the user explicitly asked for GeneralizedNewtypeDeriving,            -- we don't need to perform all of the checks we normally would,@@ -1773,9 +1543,9 @@                      , text "Use DerivingStrategies to pick"                        <+> text "a different strategy"                       ]-                 mk_originative_eqn DerivSpecAnyClass+                 mk_eqn_from_mechanism DerivSpecAnyClass                -- CanDeriveStock-               CanDeriveStock gen_fn -> mk_originative_eqn $+               CanDeriveStock gen_fn -> mk_eqn_from_mechanism $                                         DerivSpecStock gen_fn  {-@@ -2028,35 +1798,113 @@     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 = 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+doDerivInstErrorChecks1 mechanism =+  case mechanism of+    DerivSpecStock{}    -> data_cons_in_scope_check+    DerivSpecNewtype{}  -> do atf_coerce_based_error_checks+                              data_cons_in_scope_check+    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 :: DerivM ()+    data_cons_in_scope_check = do+      standalone <- isStandaloneDeriv+      when standalone $ do+        DerivEnv { denv_tc = tc, denv_rep_tc = rep_tc } <- ask+        let 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)+        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+        -- 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 -    -- ...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+        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@@ -2094,6 +1942,16 @@     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               -> TyCon -> [Type] -> [TyVar]               -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])@@ -2129,15 +1987,7 @@   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+      return (binds, faminsts, [])  {- Note [Bindings for Generalised Newtype Deriving]@@ -2226,9 +2076,12 @@  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+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,
compiler/typecheck/TcDerivInfer.hs view
@@ -22,19 +22,25 @@ 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 Type import TcSimplify import TcValidity (validDerivPred) import TcUnify (buildImplicationFor, checkConstraints)+import TysWiredIn (typeToTypeKind) import Unify (tcUnifyTy) import Util import Var@@ -66,16 +72,36 @@ -- generated method definitions should succeed.   This set will be simplified -- before being used in the instance declaration inferConstraints mechanism-  = do { DerivEnv { denv_tc          = tc+  = do { DerivEnv { denv_tvs         = tvs+                  , denv_tc          = tc                   , denv_tc_args     = tc_args                   , denv_cls         = main_cls                   , denv_cls_tys     = cls_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{}+                   -> inferConstraintsStock+                 DerivSpecAnyClass+                   -> infer_constraints_simple $ inferConstraintsAnyclass+                 DerivSpecNewtype rep_ty+                   -> infer_constraints_simple $ inferConstraintsCoerceBased rep_ty+                 DerivSpecVia     via_ty+                   -> infer_constraints_simple $ inferConstraintsCoerceBased via_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)+              inst_ty  = mkTyConApp tc tc_args              inst_tys = cls_tys ++ [inst_ty] @@ -98,20 +124,44 @@        ; 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+-- | 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 :: DerivM ([ThetaOrigin], [TyVar], [TcType])+inferConstraintsStock   = do DerivEnv { denv_tvs         = tvs+                , denv_tc          = tc+                , denv_tc_args     = tc_args                 , denv_rep_tc      = rep_tc                 , denv_rep_tc_args = rep_tc_args                 , denv_cls         = main_cls                 , denv_cls_tys     = cls_tys } <- ask        wildcard <- isStandaloneWildcardDeriv -       let tc_binders = tyConBinders rep_tc+       let inst_ty  = mkTyConApp tc tc_args+           inst_tys = cls_tys ++ [inst_ty]++           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 `mkVisFunTy` 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,13 +337,18 @@ -- 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_tc      = tc+                  , denv_tc_args = tc_args+                  , denv_cls     = cls+                  , denv_cls_tys = cls_tys } <- ask        ; wildcard <- isStandaloneWildcardDeriv -       ; let gen_dms = [ (sel_id, dm_ty)+       ; let inst_ty  = mkTyConApp tc tc_args+             inst_tys = cls_tys ++ [inst_ty]++             gen_dms = [ (sel_id, dm_ty)                        | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ]               cls_tvs = classTyVars cls@@ -320,8 +372,62 @@                                 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 -> DerivM [ThetaOrigin]+inferConstraintsCoerceBased rep_ty = do+  DerivEnv { denv_tvs     = tvs+           , denv_tc      = tycon+           , denv_tc_args = tc_args+           , denv_cls     = cls+           , denv_cls_tys = cls_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+      inst_ty    = mkTyConApp tycon tc_args+      inst_tys   = cls_tys ++ [inst_ty]+      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 +452,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@@ -456,7 +562,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
compiler/typecheck/TcDerivUtils.hs view
@@ -44,6 +44,7 @@ import TcGenDeriv import TcGenFunctor import TcGenGenerics+import TcOrigin import TcRnMonad import TcType import THNames (liftClassKey)
compiler/typecheck/TcEnv.hs view
@@ -25,6 +25,7 @@         tcLookupLocatedGlobalId, tcLookupLocatedTyCon,         tcLookupLocatedClass, tcLookupAxiom,         lookupGlobal, ioLookupDataCon,+        addTypecheckedBinds,          -- Local environment         tcExtendKindEnv, tcExtendKindEnvList,@@ -62,7 +63,7 @@         topIdLvl, isBrackStage,          -- New Ids-        newDFunName, newDFunName', newFamInstTyConName,+        newDFunName, newFamInstTyConName,         newFamInstAxiomName,         mkStableIdFromString, mkStableIdFromName,         mkWrapperName@@ -103,6 +104,7 @@ import Outputable import Encoding import FastString+import Bag import ListSetOps import ErrUtils import Maybes( MaybeErr(..), orElse )@@ -184,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 }+ {- ************************************************************************ *                                                                      *@@ -967,21 +978,6 @@                             concatMap (occNameString.getDFunTyKey) tys         ; 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]
compiler/typecheck/TcErrors.hs view
@@ -15,10 +15,13 @@  import TcRnTypes import TcRnMonad+import Constraint+import Predicate import TcMType import TcUnify( occCheckForErrors, MetaTyVarUpdateResult(..) ) import TcEnv( tcInitTidyEnv ) import TcType+import TcOrigin import RnUnbound ( unknownNameSuggestions ) import Type import TyCoRep@@ -33,11 +36,9 @@ import DataCon import TcEvidence import TcEvTerm-import GHC.Hs.Expr  ( UnboundVar(..) ) import GHC.Hs.Binds ( PatSynBind(..) ) import Name-import RdrName ( lookupGlobalRdrEnv, lookupGRE_Name, GlobalRdrEnv-               , mkRdrUnqual, isLocalGRE, greSrcSpan )+import RdrName ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual ) import PrelNames ( typeableClassName ) import Id import Var@@ -62,7 +63,6 @@ import Control.Monad    ( when ) import Data.Foldable    ( toList ) import Data.List        ( partition, mapAccumL, nub, sortBy, unfoldr )-import qualified Data.Set as Set  import {-# SOURCE #-} TcHoleErrors ( findValidHoleFits ) @@ -418,7 +418,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@@ -583,7 +583,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@@ -642,7 +642,7 @@     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 +675,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 +723,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]@@ -1098,106 +1098,64 @@  ---------------- mkHoleError :: [Ct] -> ReportErrCtxt -> Ct -> TcM ErrMsg-mkHoleError _ _ ct@(CHoleCan { cc_hole = ExprHole (OutOfScope occ rdr_env0) })-  -- Out-of-scope variables, like 'a', where 'a' isn't bound; suggest possible-  -- in-scope variables in the message, and note inaccessible exact matches-  = do { dflags   <- getDynFlags+mkHoleError tidy_simples ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort })+  | isOutOfScopeCt ct  -- Out of scope variables, like 'a', where 'a' isn't bound+                       -- Suggest possible in-scope variables in the message+  = do { dflags  <- getDynFlags+       ; rdr_env <- getGlobalRdrEnv        ; imp_info <- getImports        ; curr_mod <- getModule        ; hpt <- getHpt-       ; let suggs_msg = unknownNameSuggestions dflags hpt curr_mod rdr_env0-                                                (tcl_rdr lcl_env) imp_info rdr-       ; rdr_env     <- getGlobalRdrEnv-       ; splice_locs <- getTopLevelSpliceLocs-       ; let match_msgs = mk_match_msgs rdr_env splice_locs-       ; mkErrDocAt (RealSrcSpan err_loc) $-                    errDoc [out_of_scope_msg] [] (match_msgs ++ [suggs_msg]) }--  where-    rdr         = mkRdrUnqual occ-    ct_loc      = ctLoc ct-    lcl_env     = ctLocEnv ct_loc-    err_loc     = tcl_loc lcl_env-    hole_ty     = ctEvPred (ctEvidence ct)-    boring_type = isTyVarTy hole_ty--    out_of_scope_msg -- Print v :: ty only if the type has structure-      | boring_type = hang herald 2 (ppr occ)-      | otherwise   = hang herald 2 (pp_with_type occ hole_ty)--    herald | isDataOcc occ = text "Data constructor not in scope:"-           | otherwise     = text "Variable not in scope:"--    -- Indicate if the out-of-scope variable exactly (and unambiguously) matches-    -- a top-level binding in a later inter-splice group; see Note [OutOfScope-    -- exact matches]-    mk_match_msgs rdr_env splice_locs-      = let gres = filter isLocalGRE (lookupGlobalRdrEnv rdr_env occ)-        in case gres of-             [gre]-               |  RealSrcSpan bind_loc <- greSrcSpan gre-                  -- Find splice between the unbound variable and the match; use-                  -- lookupLE, not lookupLT, since match could be in the splice-               ,  Just th_loc <- Set.lookupLE bind_loc splice_locs-               ,  err_loc < th_loc-               -> [mk_bind_scope_msg bind_loc th_loc]-             _ -> []--    mk_bind_scope_msg bind_loc th_loc-      | is_th_bind-      = hang (quotes (ppr occ) <+> parens (text "splice on" <+> th_rng))-           2 (text "is not in scope before line" <+> int th_start_ln)-      | otherwise-      = hang (quotes (ppr occ) <+> bind_rng <+> text "is not in scope")-           2 (text "before the splice on" <+> th_rng)-      where-        bind_rng = parens (text "line" <+> int bind_ln)-        th_rng-          | th_start_ln == th_end_ln = single-          | otherwise                = multi-        single = text "line"  <+> int th_start_ln-        multi  = text "lines" <+> int th_start_ln <> text "-" <> int th_end_ln-        bind_ln     = srcSpanStartLine bind_loc-        th_start_ln = srcSpanStartLine th_loc-        th_end_ln   = srcSpanEndLine   th_loc-        is_th_bind = th_loc `containsSpan` bind_loc+       ; mkErrDocAt (RealSrcSpan (tcl_loc lcl_env)) $+                    errDoc [out_of_scope_msg] []+                           [unknownNameSuggestions dflags hpt curr_mod rdr_env+                            (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)] } -mkHoleError tidy_simples ctxt ct@(CHoleCan { cc_hole = hole })-  -- Explicit holes, like "_" or "_f"+  | otherwise  -- Explicit holes, like "_" or "_f"   = do { (ctxt, binds_msg, ct) <- relevantBindings False ctxt ct-               -- The 'False' means "don't filter the bindings"; see #8191+               -- The 'False' means "don't filter the bindings"; see Trac #8191         ; show_hole_constraints <- goptM Opt_ShowHoleConstraints        ; let constraints_msg                | isExprHoleCt ct, show_hole_constraints-                  = givenConstraintsMsg ctxt-               | otherwise = empty+               = givenConstraintsMsg ctxt+               | otherwise+               = empty         ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits        ; (ctxt, sub_msg) <- if show_valid_hole_fits                             then validHoleFits ctxt tidy_simples ct                             else return (ctxt, empty)+        ; mkErrorMsgFromCt ctxt ct $             important hole_msg `mappend`             relevant_bindings (binds_msg $$ constraints_msg) `mappend`-            valid_hole_fits sub_msg}+            valid_hole_fits sub_msg }    where-    occ       = holeOcc hole-    hole_ty   = ctEvPred (ctEvidence ct)-    hole_kind = tcTypeKind hole_ty-    tyvars    = tyCoVarsOfTypeList hole_ty+    ct_loc      = ctLoc ct+    lcl_env     = ctLocEnv ct_loc+    hole_ty     = ctEvPred (ctEvidence ct)+    hole_kind   = tcTypeKind hole_ty+    tyvars      = tyCoVarsOfTypeList hole_ty+    boring_type = isTyVarTy hole_ty -    hole_msg = case hole of-      ExprHole {} -> vcat [ hang (text "Found hole:")-                               2 (pp_with_type occ hole_ty)-                          , tyvars_msg, expr_hole_hint ]-      TypeHole {} -> vcat [ hang (text "Found type wildcard" <+>-                                  quotes (ppr occ))-                               2 (text "standing for" <+>-                                  quotes pp_hole_type_with_kind)-                          , tyvars_msg, type_hole_hint ]+    out_of_scope_msg -- Print v :: ty only if the type has structure+      | boring_type = hang herald 2 (ppr occ)+      | otherwise   = hang herald 2 pp_with_type +    pp_with_type = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty)+    herald | isDataOcc occ = text "Data constructor not in scope:"+           | otherwise     = text "Variable not in scope:"++    hole_msg = case hole_sort of+      ExprHole -> vcat [ hang (text "Found hole:")+                            2 pp_with_type+                       , tyvars_msg, expr_hole_hint ]+      TypeHole -> vcat [ hang (text "Found type wildcard" <+> quotes (ppr occ))+                            2 (text "standing for" <+> quotes pp_hole_type_with_kind)+                       , tyvars_msg, type_hole_hint ]+     pp_hole_type_with_kind       | isLiftedTypeKind hole_kind         || isCoVarType hole_ty -- Don't print the kind of unlifted@@ -1263,7 +1221,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))@@ -1272,9 +1230,6 @@          hang (text "Constraints include")             2 (vcat $ map pprConstraint constraints) -pp_with_type :: OccName -> Type -> SDoc-pp_with_type occ ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType ty)- ---------------- mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg mkIPErr ctxt cts@@ -1295,7 +1250,6 @@     (ct1:_) = cts  {-- Note [Constraints include ...] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 'givenConstraintsMsg' returns the "Constraints include ..." message enabled by@@ -1313,112 +1267,6 @@ Constraints are displayed in order from innermost (closest to the hole) to outermost. There's currently no filtering or elimination of duplicates. --Note [OutOfScope exact matches]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When constructing an out-of-scope error message, we not only generate a list of-possible in-scope alternatives but also search for an exact, unambiguous match-in a later inter-splice group.  If we find such a match, we report its presence-(and indirectly, its scope) in the message.  For example, if a module A contains-the following declarations,--   foo :: Int-   foo = x--   $(return [])  -- Empty top-level splice--   x :: Int-   x = 23--we will issue an error similar to--   A.hs:6:7: error:-       • Variable not in scope: x :: Int-       • ‘x’ (line 11) is not in scope before the splice on line 8--By providing information about the match, we hope to clarify why declaring a-variable after a top-level splice but using it before the splice generates an-out-of-scope error (a situation which is often confusing to Haskell newcomers).--Note that if we find multiple exact matches to the out-of-scope variable-(hereafter referred to as x), we report nothing.  Such matches can only be-duplicate record fields, as the presence of any other duplicate top-level-declarations would have already halted compilation.  But if these record fields-are declared in a later inter-splice group, then so too are their corresponding-types.  Thus, these types must not occur in the inter-splice group containing x-(any unknown types would have already been reported), and so the matches to the-record fields are most likely coincidental.--One oddity of the exact match portion of the error message is that we specify-where the match to x is NOT in scope.  Why not simply state where the match IS-in scope?  It most cases, this would be just as easy and perhaps a little-clearer for the user.  But now consider the following example:--    {-# LANGUAGE TemplateHaskell #-}--    module A where--    import Language.Haskell.TH-    import Language.Haskell.TH.Syntax--    foo = x--    $(do --------------------------------------------------        ds <- [d| ok1 = x-                |]-        addTopDecls ds-        return [])--    bar = $(do-            ds <- [d| x = 23-                      ok2 = x-                    |]-            addTopDecls ds-            litE $ stringL "hello")--    $(return []) -------------------------------------------    ok3 = x--Here, x is out-of-scope in the declaration of foo, and so we report--    A.hs:8:7: error:-        • Variable not in scope: x-        • ‘x’ (line 16) is not in scope before the splice on lines 10-14--If we instead reported where x IS in scope, we would have to state that it is in-scope after the second top-level splice as well as among all the top-level-declarations added by both calls to addTopDecls.  But doing so would not only-add complexity to the code but also overwhelm the user with unneeded-information.--The logic which determines where x is not in scope is straightforward: it simply-finds the last top-level splice which occurs after x but before (or at) the-match to x (assuming such a splice exists).  In most cases, the check that the-splice occurs after x acts only as a sanity check.  For example, when the match-to x is a non-TH top-level declaration and a splice S occurs before the match,-then x must precede S; otherwise, it would be in scope.  But when dealing with-addTopDecls, this check serves a practical purpose.  Consider the following-declarations:--    $(do-        ds <- [d| ok = x-                  x = 23-                |]-        addTopDecls ds-        return [])--    foo = x--In this case, x is not in scope in the declaration for foo.  Since x occurs-AFTER the splice containing the match, the logic does not find any splices after-x but before or at its match, and so we report nothing about x's scope.  If we-had not checked whether x occurs before the splice, we would have instead-reported that x is not in scope before the splice.  While correct, such an error-message is more likely to confuse than to enlighten.--}--{- ************************************************************************ *                                                                      *                 Equality errors@@ -1726,7 +1574,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 +1593,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@@ -1840,7 +1688,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]@@ -2588,7 +2436,7 @@              _  -> Just $ hang (pprTheta ev_vars_matching)                             2 (sep [ text "bound by" <+> ppr skol_info                                    , text "at" <+>-                                     ppr (tcl_loc (implicLclEnv implic)) ])+                                     ppr (tcl_loc (ic_env implic)) ])         where ev_vars_matching = [ pred                                  | ev_var <- evvars                                  , let pred = evVarPred ev_var
compiler/typecheck/TcExpr.hs view
@@ -25,6 +25,7 @@ import THNames( liftStringName, liftName )  import GHC.Hs+import Constraint       ( HoleSort(..) ) import TcHsSyn import TcRnMonad import TcUnify@@ -44,6 +45,7 @@ import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr ) import TcPat import TcMType+import TcOrigin import TcType import Id import IdInfo@@ -467,6 +469,8 @@   | 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@@ -486,7 +490,8 @@            ; Unboxed -> replicateM arity newOpenFlexiTyVarTy }        ; let actual_res_ty                  = mkVisFunTys [ty | (ty, (L _ (Missing _))) <- arg_tys `zip` tup_args]-                            (mkTupleTy boxity arg_tys)+                            (mkTupleTy1 boxity arg_tys)+                   -- See Note [Don't flatten tuples from HsSyn] in MkCore         ; wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "ExpTuple")                              (Just expr)@@ -506,6 +511,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@@ -1176,16 +1183,6 @@   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 }@@ -1237,26 +1234,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@@ -1873,7 +1850,7 @@       | otherwise                  = return ()  -tcUnboundId :: HsExpr GhcRn -> UnboundVar -> ExpRhoType -> TcM (HsExpr GhcTcId)+tcUnboundId :: HsExpr GhcRn -> OccName -> ExpRhoType -> TcM (HsExpr GhcTcId) -- Typecheck an occurrence of an unbound Id -- -- Some of these started life as a true expression hole "_".@@ -1882,12 +1859,11 @@ -- We turn all of them into HsVar, since HsUnboundVar can't contain an -- Id; and indeed the evidence for the CHoleCan does bind it, so it's -- not unbound any more!-tcUnboundId rn_expr unbound res_ty+tcUnboundId rn_expr occ res_ty  = 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+      ; can <- newHoleCt ExprHole ev ty       ; emitInsoluble can       ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr           (HsVar noExtField (noLoc ev)) ty res_ty }
compiler/typecheck/TcExpr.hs-boot view
@@ -2,7 +2,8 @@ import Name import GHC.Hs    ( HsExpr, LHsExpr, SyntaxExpr ) import TcType   ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType )-import TcRnTypes( TcM, CtOrigin )+import TcRnTypes( TcM )+import TcOrigin ( CtOrigin ) import GHC.Hs.Extension ( GhcRn, GhcTcId )  tcPolyExpr ::@@ -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
@@ -3,6 +3,7 @@ module TcFlatten(    FlattenMode(..),    flatten, flattenKind, flattenArgsNom,+   rewriteTyVar,     unflattenWanteds  ) where@@ -12,6 +13,8 @@ import GhcPrelude  import TcRnTypes+import Constraint+import Predicate import TcType import Type import TcEvidence@@ -454,7 +457,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]@@ -518,7 +522,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 }@@ -741,8 +746,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@@ -751,8 +775,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)@@ -763,6 +806,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@@ -809,11 +853,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,@@ -1362,7 +1409,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')                            }@@ -1397,7 +1444,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')                                  }@@ -1435,7 +1482,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@@ -1461,7 +1508,7 @@                Just (norm_co, norm_ty)                  -> do { (xi, final_co) <- bumpDepth $ flatten_one norm_ty                        ; eq_rel <- getEqRel-                       ; let co  = mkSymCo (maybeSubCo eq_rel norm_co+                       ; let co  = mkSymCo (maybeTcSubCo eq_rel norm_co                                             `mkTransCo` mkSymCo final_co)                        ; return $ Just (xi, co) }                Nothing -> pure Nothing }@@ -1533,7 +1580,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'@@ -1573,7 +1620,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 <+>
compiler/typecheck/TcGenDeriv.hs view
@@ -1441,7 +1441,7 @@   kind1, kind2 :: Kind-kind1 = liftedTypeKind `mkVisFunTy` liftedTypeKind+kind1 = typeToTypeKind kind2 = liftedTypeKind `mkVisFunTy` kind1  gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
compiler/typecheck/TcGenGenerics.hs view
@@ -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]
compiler/typecheck/TcHoleErrors.hs view
@@ -18,6 +18,8 @@  import TcRnTypes import TcRnMonad+import Constraint+import TcOrigin import TcMType import TcEvidence import TcType@@ -51,7 +53,7 @@ import ExtractDocs ( extractDocs ) import qualified Data.Map as Map import GHC.Hs.Doc      ( unpackHDS, DeclDocMap(..) )-import HscTypes        ( ModIface(..) )+import HscTypes        ( ModIface_(..) ) import LoadIface       ( loadInterfaceForNameMaybe )  import PrelInfo (knownKeyNames)
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,          -- * Other HsSyn functions         mkHsDictLet, mkHsApp,@@ -51,6 +51,7 @@ import GHC.Hs import Id import IdInfo+import Predicate import TcRnMonad import PrelNames import BuildTyCl ( TcMethInfo, MethInfo )@@ -96,21 +97,19 @@  -} -hsLPatType :: OutPat GhcTc -> Type-hsLPatType lpat = hsPatType (unLoc lpat)- hsPatType :: Pat GhcTc -> Type-hsPatType (ParPat _ pat)                = hsLPatType pat+hsPatType (ParPat _ pat)                = hsPatType pat hsPatType (WildPat ty)                  = ty hsPatType (VarPat _ lvar)               = idType (unLoc lvar)-hsPatType (BangPat _ pat)               = hsLPatType pat-hsPatType (LazyPat _ pat)               = hsLPatType pat+hsPatType (BangPat _ pat)               = hsPatType pat+hsPatType (LazyPat _ pat)               = hsPatType pat hsPatType (LitPat _ lit)                = hsLitType lit hsPatType (AsPat _ var _)               = idType (unLoc var) 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 +118,10 @@ hsPatType (NPat ty _ _ _)               = ty hsPatType (NPlusKPat ty _ _ _ _ _)      = ty hsPatType (CoPat _ _ _ ty)              = ty-hsPatType p                             = pprPanic "hsPatType" (ppr p)+-- XPat wraps a Located (Pat GhcTc) in GhcTc+hsPatType (XPat lpat)                   = hsPatType (unLoc lpat)+hsPatType ConPatIn{}                    = panic "hsPatType: ConPatIn"+hsPatType SplicePat{}                   = panic "hsPatType: SplicePat"  hsLitType :: HsLit (GhcPass p) -> TcType hsLitType (HsChar _ _)       = charTy@@ -959,7 +961,8 @@        new_expr <- zonkExpr env1 expr        return (HsWrap x new_co_fn new_expr) -zonkExpr _ e@(HsUnboundVar {}) = return e+zonkExpr _ e@(HsUnboundVar {})+  = return e  zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
compiler/typecheck/TcHsType.hs view
@@ -71,6 +71,9 @@  import GHC.Hs import TcRnMonad+import TcOrigin+import Predicate+import Constraint import TcEvidence import TcEnv import TcMType@@ -1290,7 +1293,7 @@  Note [mkAppTyM] ~~~~~~~~~~~~~~~-mkAppTyM is trying to guaranteed the Purely Kinded Type Invariant+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)@@ -1674,7 +1677,7 @@ 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 TcRnTypes+See also Note [Checking telescopes] in Constraint  Note [Keeping scoped variables in order: Implicit] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/typecheck/TcInstDcls.hs view
@@ -29,6 +29,8 @@ import TcHsSyn import TcMType import TcType+import Constraint+import TcOrigin import BuildTyCl import Inst import ClsInst( AssocInstInfo(..), isNotAssociated )@@ -1660,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
compiler/typecheck/TcInteract.hs view
@@ -35,6 +35,9 @@ import Outputable  import TcRnTypes+import Constraint+import Predicate+import TcOrigin import TcSMonad import Bag import MonadUtils ( concatMapM, foldlM )@@ -1181,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) }  {- **********************************************************************@@ -1336,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]@@ -1860,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+ -}  --------------------@@ -1891,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@@ -1905,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 ]@@ -1919,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 #14778+    loc = bumpCtLocDepth (ctEvLoc ev)+        -- ToDo: this location is wrong; it should be FunDepOrigin2+        -- See #14778  improve_top_fun_eqs :: FamInstEnvs                     -> TyCon -> [TcType] -> TcType@@ -2252,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) $@@ -2610,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
@@ -48,6 +48,8 @@   unpackCoercionHole, unpackCoercionHole_maybe,   checkCoercionHole, +  newImplication,+   --------------------------------   -- Instantiation   newMetaTyVars, newMetaTyVarX, newMetaTyVarsX,@@ -98,9 +100,12 @@ import Coercion import Class import Var+import Predicate+import TcOrigin  -- others: import TcRnMonad        -- TcType, amongst others+import Constraint import TcEvidence import Id import Name@@ -116,7 +121,9 @@ import Bag import Pair import UniqSet+import DynFlags import qualified GHC.LanguageExtensions as LangExt+import BasicTypes ( TypeOrKind(..) )  import Control.Monad import Maybes@@ -183,13 +190,14 @@ newWanteds orig = mapM (newWanted orig Nothing)  -- | Create a new 'CHoleCan' 'Ct'.-newHoleCt :: Hole -> Id -> Type -> TcM Ct+newHoleCt :: HoleSort -> Id -> Type -> TcM Ct newHoleCt hole ev ty = do   loc <- getCtLocM HoleOrigin Nothing   pure $ CHoleCan { cc_ev = CtWanted { ctev_pred = ty                                      , ctev_dest = EvVarDest ev                                      , ctev_nosh = WDeriv                                      , ctev_loc  = loc }+                  , cc_occ = getOccName ev                   , cc_hole = hole }  ----------------------------------------------@@ -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 })+ {- ************************************************************************ *                                                                      *@@ -1966,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,@@ -2011,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@@ -2210,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@@ -2256,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
compiler/typecheck/TcMatches.hs view
@@ -21,7 +21,7 @@  import GhcPrelude -import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferSigmaNC, tcInferSigma+import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho                               , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr )  import BasicTypes (LexicalFixity(..))@@ -33,6 +33,7 @@ import TcType import TcBinds import TcUnify+import TcOrigin import Name import TysWiredIn import Id@@ -404,7 +405,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) $@@ -478,7 +479,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') } @@ -616,16 +617,15 @@                          , 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 `mkVisFunTy` 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)@@ -741,8 +741,7 @@ --        -> m (st1, (st2, st3)) -- tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside-  = do { let star_star_kind = liftedTypeKind `mkVisFunTy` liftedTypeKind-       ; m_ty   <- newFlexiTyVarTy star_star_kind+  = do { m_ty   <- newFlexiTyVarTy typeToTypeKind         ; let mzip_ty  = mkInvForAllTys [alphaTyVar, betaTyVar] $                         (m_ty `mkAppTy` alphaTy)
compiler/typecheck/TcPat.hs view
@@ -39,6 +39,7 @@ 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:
compiler/typecheck/TcPatSyn.hs view
@@ -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@@ -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@@ -405,7 +406,7 @@        ; 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,
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(HAVE_INTERPRETER)         -- * Basic TcPluginM functionality         TcPluginM,         tcPluginIO,@@ -49,10 +48,8 @@         newEvVar,         setEvBind,         getEvBindsTcPluginM-#endif     ) where -#if defined(HAVE_INTERPRETER) 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
@@ -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 )@@ -163,7 +165,7 @@ 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 $@@ -271,8 +273,10 @@                       ; tcg_env <- tcRnExports explicit_mod_hdr export_ies                                      tcg_env                       ; traceRn "rn4b: after exports" empty-                      ; -- Check main is exported(must be after tcRnExports)-                        checkMainExported tcg_env+                      ; -- When a module header is specified,+                        -- check that the main module exports a main function.+                        -- (must be after tcRnExports)+                        when explicit_mod_hdr $ checkMainExported tcg_env                       ; -- Compare hi-boot iface (if any) with the real thing                         -- Must be done after processing the exports                         tcg_env <- checkHiBootIface tcg_env boot_info@@ -292,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@@ -584,8 +588,11 @@           { Nothing -> return (tcg_env, tcl_env, lie1)              -- If there's a splice, we must carry on-          ; Just (SpliceDecl _ (dL->L loc splice) _, rest_ds) ->-            do { recordTopLevelSpliceLoc loc+          ; Just (SpliceDecl _ (dL->L _ splice) _, rest_ds) ->+            do {+                 -- We need to simplify any constraints from the previous declaration+                 -- group, or else we might reify metavariables, as in #16980.+               ; ev_binds1 <- simplifyTop lie1                   -- Rename the splice expression, and get its supporting decls                ; (spliced_decls, splice_fvs) <- rnTopSpliceDecls splice@@ -593,9 +600,10 @@                  -- Glue them on the front of the remaining decls and loop                ; (tcg_env, tcl_env, lie2) <-                    setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $+                   addTopEvBinds ev_binds1 $                    tc_rn_src_decls (spliced_decls ++ rest_ds) -               ; return (tcg_env, tcl_env, lie1 `andWC` lie2)+               ; return (tcg_env, tcl_env, lie2)                }           ; Just (XSpliceDecl nec, _) -> noExtCon nec           }@@ -1801,11 +1809,10 @@       Just main_name ->          do { dflags <- getDynFlags             ; let main_mod = mainModIs dflags-            ; when (ghcLink dflags /= LinkInMemory) $      -- #11647-                checkTc (main_name `elem`+            ; checkTc (main_name `elem`                            concatMap availNames (tcg_exports tcg_env)) $-                   text "The" <+> ppMainFn (nameRdrName main_name) <+>-                   text "is not exported by module" <+> quotes (ppr main_mod) }+                text "The" <+> ppMainFn (nameRdrName main_name) <+>+                text "is not exported by module" <+> quotes (ppr main_mod) }  ppMainFn :: RdrName -> SDoc ppMainFn main_fn
compiler/typecheck/TcRnMonad.hs view
@@ -107,8 +107,8 @@   emitNamedWildCardHoleConstraints, emitAnonWildCardHoleConstraint,    -- * Template Haskell context-  recordThUse, recordThSpliceUse, recordTopLevelSpliceLoc,-  getTopLevelSpliceLocs, keepAlive, getStage, getStageAndBindLevel, setStage,+  recordThUse, recordThSpliceUse,+  keepAlive, getStage, getStageAndBindLevel, setStage,   addModFinalizersWithLclEnv,    -- * Safe Haskell context@@ -146,7 +146,9 @@  import TcRnTypes        -- Re-export all import IOEnv            -- Re-export all+import Constraint import TcEvidence+import TcOrigin  import GHC.Hs hiding (LIE) import HscTypes@@ -175,7 +177,7 @@ import Panic import Util import Annotations-import BasicTypes( TopLevelFlag )+import BasicTypes( TopLevelFlag, TypeOrKind(..) ) import Maybes import CostCentreState @@ -183,8 +185,6 @@  import Data.IORef import Control.Monad-import Data.Set ( Set )-import qualified Data.Set as Set  import {-# SOURCE #-} TcEnv    ( tcInitTidyEnv ) @@ -214,7 +214,6 @@         used_gre_var <- newIORef [] ;         th_var       <- newIORef False ;         th_splice_var<- newIORef False ;-        th_locs_var  <- newIORef Set.empty ;         infer_var    <- newIORef (True, emptyBag) ;         dfun_n_var   <- newIORef emptyOccSet ;         type_env_var <- case hsc_type_env_var hsc_env of {@@ -274,8 +273,6 @@                 tcg_ann_env        = emptyAnnEnv,                 tcg_th_used        = th_var,                 tcg_th_splice_used = th_splice_var,-                tcg_th_top_level_locs-                                   = th_locs_var,                 tcg_exports        = [],                 tcg_imports        = emptyImportAvails,                 tcg_used_gres     = used_gre_var,@@ -1681,7 +1678,8 @@        ; emitInsolubles $ unitBag $          CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv                                       , ctev_loc  = ct_loc }-                  , cc_hole = TypeHole (mkTyVarOcc "_") } }+                  , cc_occ = mkTyVarOcc "_"+                  , cc_hole = TypeHole } }  emitNamedWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM () emitNamedWildCardHoleConstraints wcs@@ -1693,7 +1691,8 @@     do_one ct_loc (name, tv)        = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv                                       , ctev_loc  = ct_loc' }-                  , cc_hole = TypeHole (occName name) }+                  , cc_occ = occName name+                  , cc_hole = TypeHole }        where          real_span = case nameSrcSpan name of                            RealSrcSpan span  -> span@@ -1767,22 +1766,6 @@  recordThSpliceUse :: TcM () recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }---- | When generating an out-of-scope error message for a variable matching a--- binding in a later inter-splice group, the typechecker uses the splice--- locations to provide details in the message about the scope of that binding.-recordTopLevelSpliceLoc :: SrcSpan -> TcM ()-recordTopLevelSpliceLoc (RealSrcSpan real_loc)-  = do { env <- getGblEnv-       ; let locs_var = tcg_th_top_level_locs env-       ; locs0 <- readTcRef locs_var-       ; writeTcRef locs_var (Set.insert real_loc locs0) }-recordTopLevelSpliceLoc (UnhelpfulSpan _) = return ()--getTopLevelSpliceLocs :: TcM (Set RealSrcSpan)-getTopLevelSpliceLocs-  = do { env <- getGblEnv-       ; readTcRef (tcg_th_top_level_locs env) }  keepAlive :: Name -> TcRn ()     -- Record the name in the keep-alive set keepAlive name
compiler/typecheck/TcRules.hs view
@@ -17,6 +17,9 @@ import TcRnTypes import TcRnMonad import TcSimplify+import Constraint+import Predicate+import TcOrigin import TcMType import TcType import TcHsType
compiler/typecheck/TcSMonad.hs view
@@ -19,7 +19,7 @@     nestTcS, nestImplicTcS, setEvBindsTcS,     checkConstraintsTcS, checkTvConstraintsTcS, -    runTcPluginTcS, addUsedGRE, addUsedGREs,+    runTcPluginTcS, addUsedGRE, addUsedGREs, keepAlive,     matchGlobalInst, TcM.ClsInstResult(..),      QCInst(..),@@ -79,7 +79,7 @@      -- Inert CTyEqCans     EqualCtList, findTyEqs, foldTyEqs, isInInertEqs,-    lookupFlattenTyVar, lookupInertTyVar,+    lookupInertTyVar,      -- Inert solved dictionaries     addSolvedDict, lookupSolvedDict,@@ -139,7 +139,7 @@ import qualified ClsInst as TcM( matchGlobalInst, ClsInstResult(..) ) import qualified TcEnv as TcM        ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl )-import ClsInst( InstanceWhat(..) )+import ClsInst( InstanceWhat(..), safeOverlap, instanceReturnsDictCon ) import Kind import TcType import DynFlags@@ -164,6 +164,9 @@ import UniqSupply import Util import TcRnTypes+import TcOrigin+import Constraint+import Predicate  import Unique import UniqFM@@ -230,7 +233,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@@ -254,6 +257,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]@@ -483,6 +487,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 +551,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 +561,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 +764,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1043,7 +1103,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@@ -1459,25 +1519,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@@ -1663,7 +1704,7 @@      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)@@ -1834,10 +1875,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 +1888,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) }@@ -2872,7 +2915,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@@ -2911,7 +2954,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@@ -3066,6 +3109,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] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -3225,6 +3270,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,@@ -3379,7 +3425,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 }) }@@ -3504,11 +3550,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
@@ -31,6 +31,7 @@ import TcHsType import TcRnTypes import TcRnMonad+import TcOrigin import TcType import TcMType import TcValidity ( checkValidType )
compiler/typecheck/TcSimplify.hs view
@@ -31,7 +31,6 @@ import Bag import Class         ( Class, classKey, classTyCon ) import DynFlags-import GHC.Hs.Expr   ( UnboundVar(..) ) import Id            ( idType, mkLocalId ) import Inst import ListSetOps@@ -39,7 +38,6 @@ import Outputable import PrelInfo import PrelNames-import RdrName       ( emptyGlobalRdrEnv ) import TcErrors import TcEvidence import TcInteract@@ -47,6 +45,9 @@ import TcMType   as TcM import TcRnMonad as TcM import TcSMonad  as TcS+import Constraint+import Predicate+import TcOrigin import TcType import Type import TysWiredIn    ( liftedRepTy )@@ -657,8 +658,7 @@       let occ = mkVarOcc "$tcNorm"       name <- newSysName occ       let ev = mkLocalId name ty-          hole = ExprHole $ OutOfScope occ emptyGlobalRdrEnv-      newHoleCt hole ev ty+      newHoleCt ExprHole ev ty  {- Note [Superclasses and satisfiability] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -838,7 +838,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) @@ -857,13 +857,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@@ -876,23 +876,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 ]@@ -1666,7 +1665,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
compiler/typecheck/TcSplice.hs view
@@ -46,6 +46,7 @@ import THNames import TcUnify import TcEnv+import TcOrigin import Coercion( etaExpandCoAxBranch ) import FileCleanup ( newTempName, TempFileLifetime(..) ) @@ -1478,13 +1479,11 @@   = do { tvs' <- reifyTyVarsToMaybe tvs        ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs        ; lhs' <- reifyTypes lhs_types_only-       ; annot_th_lhs <- zipWith3M annotThType (mkIsPolyTvs fam_tvs)+       ; annot_th_lhs <- zipWith3M annotThType (tyConArgsPolyKinded fam_tc)                                    lhs_types_only lhs'        ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam_tc) annot_th_lhs        ; rhs'  <- reifyType rhs        ; return (TH.TySynEqn tvs' lhs_type rhs') }-  where-    fam_tvs = tyConVisibleTyVars fam_tc  reifyTyCon :: TyCon -> TcM TH.Info reifyTyCon tc@@ -1713,7 +1712,8 @@ -- | Annotate (with TH.SigT) a type if the first parameter is True -- and if the type contains a free variable. -- This is used to annotate type patterns for poly-kinded tyvars in--- reifying class and type instances. See #8953 and th/T8953.+-- reifying class and type instances.+-- See @Note [Reified instances and explicit kind signatures]@. annotThType :: Bool   -- True <=> annotate             -> TyCoRep.Type -> TH.Type -> TcM TH.Type   -- tiny optimization: if the type is annotated, don't annotate again.@@ -1725,24 +1725,116 @@        ; return (TH.SigT th_ty th_ki) } annotThType _    _ th_ty = return th_ty --- | For every type variable in the input,--- report whether or not the tv is poly-kinded. This is used to eventually--- feed into 'annotThType'.-mkIsPolyTvs :: [TyVar] -> [Bool]-mkIsPolyTvs = map is_poly_tv+-- | For every argument type that a type constructor accepts,+-- report whether or not the argument is poly-kinded. This is used to+-- eventually feed into 'annotThType'.+-- See @Note [Reified instances and explicit kind signatures]@.+tyConArgsPolyKinded :: TyCon -> [Bool]+tyConArgsPolyKinded tc =+     map (is_poly_ty . tyVarKind)      tc_vis_tvs+     -- See "Wrinkle: Oversaturated data family instances" in+     -- @Note [Reified instances and explicit kind signatures]@+  ++ map (is_poly_ty . tyCoBinderType) tc_res_kind_vis_bndrs -- (1) in Wrinkle+  ++ repeat True                                             -- (2) in Wrinkle   where-    is_poly_tv tv = not $+    is_poly_ty :: Type -> Bool+    is_poly_ty ty = not $                     isEmptyVarSet $                     filterVarSet isTyVar $-                    tyCoVarsOfType $-                    tyVarKind tv+                    tyCoVarsOfType ty +    tc_vis_tvs :: [TyVar]+    tc_vis_tvs = tyConVisibleTyVars tc++    tc_res_kind_vis_bndrs :: [TyCoBinder]+    tc_res_kind_vis_bndrs = filter isVisibleBinder $ fst $ splitPiTys $ tyConResKind tc++{-+Note [Reified instances and explicit kind signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Reified class instances and type family instances often include extra kind+information to disambiguate instances. Here is one such example that+illustrates this (#8953):++    type family Poly (a :: k) :: Type+    type instance Poly (x :: Bool)    = Int+    type instance Poly (x :: Maybe k) = Double++If you're not careful, reifying these instances might yield this:++    type instance Poly x = Int+    type instance Poly x = Double++To avoid this, we go through some care to annotate things with extra kind+information. Some functions which accomplish this feat include:++* annotThType: This annotates a type with a kind signature if the type contains+  a free variable.+* tyConArgsPolyKinded: This checks every argument that a type constructor can+  accept and reports if the type of the argument is poly-kinded. This+  information is ultimately fed into annotThType.++-----+-- Wrinkle: Oversaturated data family instances+-----++What constitutes an argument to a type constructor in the definition of+tyConArgsPolyKinded? For most type constructors, it's simply the visible+type variable binders (i.e., tyConVisibleTyVars). There is one corner case+we must keep in mind, however: data family instances can appear oversaturated+(#17296). For instance:++    data family   Foo :: Type -> Type+    data instance Foo x++    data family Bar :: k+    data family Bar x++For these sorts of data family instances, tyConVisibleTyVars isn't enough,+as they won't give you the kinds of the oversaturated arguments. We must+also consult:++1. The kinds of the arguments in the result kind (i.e., the tyConResKind).+   This will tell us, e.g., the kind of `x` in `Foo x` above.+2. If we go beyond the number of arguments in the result kind (like the+   `x` in `Bar x`), then we conservatively assume that the argument's+   kind is poly-kinded.++-----+-- Wrinkle: data family instances with return kinds+-----++Another squirrelly corner case is this:++    data family Foo (a :: k)+    data instance Foo :: Bool -> Type+    data instance Foo :: Char -> Type++If you're not careful, reifying these instances might yield this:++    data instance Foo+    data instance Foo++We can fix this ambiguity by reifying the instances' explicit return kinds. We+should only do this if necessary (see+Note [When does a tycon application need an explicit kind signature?] in Type),+but more importantly, we *only* do this if either of the following are true:++1. The data family instance has no constructors.+2. The data family instance is declared with GADT syntax.++If neither of these are true, then reifying the return kind would yield+something like this:++    data instance (Bar a :: Type) = MkBar a++Which is not valid syntax.+-}+ ------------------------------ reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec] reifyClassInstances cls insts-  = mapM (reifyClassInstance (mkIsPolyTvs tvs)) insts-  where-    tvs = tyConVisibleTyVars (classTyCon cls)+  = mapM (reifyClassInstance (tyConArgsPolyKinded (classTyCon cls))) insts  reifyClassInstance :: [Bool]  -- True <=> the corresponding tv is poly-kinded                               -- includes only *visible* tvs@@ -1768,9 +1860,7 @@ ------------------------------ reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec] reifyFamilyInstances fam_tc fam_insts-  = mapM (reifyFamilyInstance (mkIsPolyTvs fam_tvs)) fam_insts-  where-    fam_tvs = tyConVisibleTyVars fam_tc+  = mapM (reifyFamilyInstance (tyConArgsPolyKinded fam_tc)) fam_insts  reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded                               -- includes only *visible* tvs@@ -1807,10 +1897,19 @@            ; th_tys <- reifyTypes types_only            ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys            ; let lhs_type = mkThAppTs (TH.ConT fam') annot_th_tys+           ; mb_sig <-+               -- See "Wrinkle: data family instances with return kinds" in+               -- Note [Reified instances and explicit kind signatures]+               if (null cons || isGadtSyntaxTyCon rep_tc)+                     && tyConAppNeedsKindSig False fam_tc (length ee_lhs)+               then do { let full_kind = tcTypeKind (mkTyConApp fam_tc ee_lhs)+                       ; th_full_kind <- reifyKind full_kind+                       ; pure $ Just th_full_kind }+               else pure Nothing            ; return $                if isNewTyCon rep_tc-               then TH.NewtypeInstD [] th_tvs lhs_type Nothing (head cons) []-               else TH.DataInstD    [] th_tvs lhs_type Nothing       cons  []+               then TH.NewtypeInstD [] th_tvs lhs_type mb_sig (head cons) []+               else TH.DataInstD    [] th_tvs lhs_type mb_sig       cons  []            }  ------------------------------
compiler/typecheck/TcTyClsDecls.hs view
@@ -47,6 +47,7 @@ import FamInst import FamInstEnv import Coercion+import TcOrigin import Type import TyCoRep   -- for checkValidRoles import Class
compiler/typecheck/TcTyDecls.hs view
@@ -33,9 +33,10 @@  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 GHC.Hs
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
compiler/typecheck/TcTypeable.hs view
@@ -8,20 +8,19 @@ {-# 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 )@@ -46,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]@@ -254,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@@ -414,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@@ -575,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) @@ -673,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
@@ -48,6 +48,9 @@ import Type import Coercion import TcEvidence+import Constraint+import Predicate+import TcOrigin import Name( isSystemName ) import Inst import TyCon@@ -927,35 +930,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.+ -}  {- *********************************************************************@@ -1180,7 +1211,7 @@   , 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 TcRnTypes.+    -- wanted constraints. See Note [Checking telescopes] in Constraint.     -- Lacking this check led to #16247   = return ()
compiler/typecheck/TcValidity.hs view
@@ -38,6 +38,8 @@ import CoAxiom import Class import TyCon+import Predicate+import TcOrigin  -- others: import IfaceType( pprIfaceType, pprIfaceTypeApp )@@ -53,7 +55,6 @@ import VarEnv import VarSet import Var         ( VarBndr(..), mkTyVar )-import Id          ( idType, idName ) import FV import ErrUtils import DynFlags@@ -356,7 +357,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@@ -676,7 +679,7 @@ 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@@ -1270,17 +1273,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@@ -1474,7 +1470,8 @@   = do { dflags   <- getDynFlags        ; is_boot  <- tcIsHsBootOrSig        ; is_sig   <- tcIsHsig-       ; check_valid_inst_head dflags is_boot is_sig ctxt clas cls_args+       ; check_special_inst_head dflags is_boot is_sig ctxt clas cls_args+       ; checkValidTypePats (classTyCon clas) cls_args        }  {-@@ -1502,10 +1499,10 @@  -} -check_valid_inst_head :: DynFlags -> Bool -> Bool-                      -> UserTypeCtxt -> Class -> [Type] -> TcM ()+check_special_inst_head :: DynFlags -> Bool -> Bool+                        -> UserTypeCtxt -> Class -> [Type] -> TcM () -- Wow!  There are a surprising number of ad-hoc special cases here.-check_valid_inst_head dflags is_boot is_sig ctxt clas cls_args+check_special_inst_head dflags is_boot is_sig ctxt clas cls_args    -- If not in an hs-boot file, abstract classes cannot have instances   | isAbstractClass clas@@ -1555,7 +1552,7 @@   = failWithTc (instTypeErr clas cls_args msg)    | otherwise-  = checkValidTypePats (classTyCon clas) cls_args+  = pure ()   where     clas_nm = getName clas     ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args@@ -2030,11 +2027,12 @@      -- 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) }+                   (makeInjectivityErrors dflags ax cur_branch inj conflicts) }       | otherwise       = return () @@ -2172,9 +2170,11 @@        }   where     pat_tvs     = tyCoVarsOfTypes pats-    inj_pat_tvs = fvVarSet $ injectiveVarsOfTypes 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
+ 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)
+
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 0.20191002+version: 0.20191101 license: BSD3 license-file: LICENSE category: Development@@ -18,13 +18,13 @@     llvm-passes     platformConstants extra-source-files:-    ghc-lib/generated/ghcautoconf.h-    ghc-lib/generated/ghcplatform.h-    ghc-lib/generated/ghcversion.h-    ghc-lib/generated/DerivedConstants.h-    ghc-lib/generated/GHCConstantsHaskellExports.hs-    ghc-lib/generated/GHCConstantsHaskellType.hs-    ghc-lib/generated/GHCConstantsHaskellWrappers.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@@ -40,9 +40,9 @@     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     includes/ghcconfig.h     includes/MachDeps.h+    includes/stg/MachRegs.h     includes/CodeGen.Platform.hs     compiler/HsVersions.h     compiler/Unique.h@@ -56,12 +56,12 @@     default-extensions: NoImplicitPrelude     include-dirs:         includes-        ghc-lib/generated+        ghc-lib/stage0/lib         ghc-lib/stage0/compiler/build         compiler     ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS     cc-options: -DTHREADED_RTS-    cpp-options: -DSTAGE=2 -DTHREADED_RTS -DHAVE_INTERPRETER -DGHC_IN_GHCI+    cpp-options:  -DTHREADED_RTS  -DGHC_IN_GHCI     if !os(windows)         build-depends: unix     else@@ -81,7 +81,7 @@         transformers == 0.5.*,         process >= 1 && < 1.7,         hpc == 0.6.*,-        ghc-lib-parser == 0.20191002+        ghc-lib-parser == 0.20191101     build-tools: alex >= 3.1, happy >= 1.19.4     other-extensions:         BangPatterns@@ -117,6 +117,7 @@         UnboxedTuples         UndecidableInstances     hs-source-dirs:+        ghc-lib/stage0/libraries/ghc-boot/build         ghc-lib/stage0/compiler/build         libraries/template-haskell         compiler/specialise@@ -166,6 +167,7 @@         ConLike,         Config,         Constants,+        Constraint,         CoreArity,         CoreFVs,         CoreMap,@@ -226,6 +228,7 @@         GHC.Hs.PlaceHolder,         GHC.Hs.Types,         GHC.Hs.Utils,+        GHC.HsToCore.PmCheck.Types,         GHC.LanguageExtensions,         GHC.LanguageExtensions.Type,         GHC.Lexeme,@@ -293,9 +296,9 @@         PlainPanic,         PlatformConstants,         Plugins,-        PmTypes,         PprColour,         PprCore,+        Predicate,         PrelNames,         PrelRules,         Pretty,@@ -312,6 +315,7 @@         SysTools.Terminal,         TcEvidence,         TcHoleFitTypes,+        TcOrigin,         TcRnTypes,         TcType,         ToIface,@@ -357,7 +361,6 @@         CPrim         CSE         CallArity-        Check         ClsInst         Cmm         CmmBuildInfoTables@@ -390,6 +393,7 @@         Debugger         Desugar         DmdAnal+        Dominators         DriverBkp         DriverMkDepend         DriverPipeline@@ -421,11 +425,16 @@         GHC         GHC.HandleEncoding         GHC.Hs.Dump+        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@@ -511,8 +520,6 @@         PPC.Ppr         PPC.RegInfo         PPC.Regs-        PmOracle-        PmPpr         PprBase         PprC         PprCmm@@ -603,6 +610,7 @@         SysTools.ExtraObj         SysTools.Info         SysTools.Process+        SysTools.Settings         SysTools.Tasks         THNames         TargetReg@@ -648,7 +656,6 @@         TcTyDecls         TcTypeNats         TcTypeable-        TcTypeableValidity         TcUnify         TcValidity         TidyPgm
− ghc-lib/generated/DerivedConstants.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/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,133 +0,0 @@-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/generated/GHCConstantsHaskellWrappers.hs 
@@ -1,250 +0,0 @@-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/generated/ghcautoconf.h 
@@ -1,542 +0,0 @@-#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 __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 $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 <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 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 (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,26 +0,0 @@-#if !defined(__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"---#endif /* __GHCPLATFORM_H__ */
− ghc-lib/generated/ghcversion.h 
@@ -1,19 +0,0 @@-#if !defined(__GHCVERSION_H__)-#define __GHCVERSION_H__--#if !defined(__GLASGOW_HASKELL__)-# define __GLASGOW_HASKELL__ 809-#endif--#define __GLASGOW_HASKELL_PATCHLEVEL1__ 0-#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190928--#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/compiler/build/ghc_boot_platform.h 
@@ -1,25 +0,0 @@-#if !defined(__PLATFORM_H__)-#define __PLATFORM_H__--#define BuildPlatform_NAME  "x86_64-apple-darwin"-#define HostPlatform_NAME   "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 /* __PLATFORM_H__ */
ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl view
@@ -244,10 +244,12 @@    | CasArrayOp    | NewSmallArrayOp    | SameSmallMutableArrayOp+   | ShrinkSmallMutableArrayOp_Char    | ReadSmallArrayOp    | WriteSmallArrayOp    | SizeofSmallArrayOp    | SizeofSmallMutableArrayOp+   | GetSizeofSmallMutableArrayOp    | IndexSmallArrayOp    | UnsafeFreezeSmallArrayOp    | UnsafeThawSmallArrayOp
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
ghc-lib/stage0/compiler/build/primop-list.hs-incl view
@@ -243,10 +243,12 @@    , CasArrayOp    , NewSmallArrayOp    , SameSmallMutableArrayOp+   , ShrinkSmallMutableArrayOp_Char    , ReadSmallArrayOp    , WriteSmallArrayOp    , SizeofSmallArrayOp    , SizeofSmallMutableArrayOp+   , GetSizeofSmallMutableArrayOp    , IndexSmallArrayOp    , UnsafeFreezeSmallArrayOp    , UnsafeThawSmallArrayOp
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
ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl view
@@ -243,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]))
ghc-lib/stage0/compiler/build/primop-tag.hs-incl view
@@ -1,1204 +1,1206 @@ maxPrimOpTag :: Int-maxPrimOpTag = 1201-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 ReadSmallArrayOp = 246-primOpTag WriteSmallArrayOp = 247-primOpTag SizeofSmallArrayOp = 248-primOpTag SizeofSmallMutableArrayOp = 249-primOpTag IndexSmallArrayOp = 250-primOpTag UnsafeFreezeSmallArrayOp = 251-primOpTag UnsafeThawSmallArrayOp = 252-primOpTag CopySmallArrayOp = 253-primOpTag CopySmallMutableArrayOp = 254-primOpTag CloneSmallArrayOp = 255-primOpTag CloneSmallMutableArrayOp = 256-primOpTag FreezeSmallArrayOp = 257-primOpTag ThawSmallArrayOp = 258-primOpTag CasSmallArrayOp = 259-primOpTag NewByteArrayOp_Char = 260-primOpTag NewPinnedByteArrayOp_Char = 261-primOpTag NewAlignedPinnedByteArrayOp_Char = 262-primOpTag MutableByteArrayIsPinnedOp = 263-primOpTag ByteArrayIsPinnedOp = 264-primOpTag ByteArrayContents_Char = 265-primOpTag SameMutableByteArrayOp = 266-primOpTag ShrinkMutableByteArrayOp_Char = 267-primOpTag ResizeMutableByteArrayOp_Char = 268-primOpTag UnsafeFreezeByteArrayOp = 269-primOpTag SizeofByteArrayOp = 270-primOpTag SizeofMutableByteArrayOp = 271-primOpTag GetSizeofMutableByteArrayOp = 272-primOpTag IndexByteArrayOp_Char = 273-primOpTag IndexByteArrayOp_WideChar = 274-primOpTag IndexByteArrayOp_Int = 275-primOpTag IndexByteArrayOp_Word = 276-primOpTag IndexByteArrayOp_Addr = 277-primOpTag IndexByteArrayOp_Float = 278-primOpTag IndexByteArrayOp_Double = 279-primOpTag IndexByteArrayOp_StablePtr = 280-primOpTag IndexByteArrayOp_Int8 = 281-primOpTag IndexByteArrayOp_Int16 = 282-primOpTag IndexByteArrayOp_Int32 = 283-primOpTag IndexByteArrayOp_Int64 = 284-primOpTag IndexByteArrayOp_Word8 = 285-primOpTag IndexByteArrayOp_Word16 = 286-primOpTag IndexByteArrayOp_Word32 = 287-primOpTag IndexByteArrayOp_Word64 = 288-primOpTag IndexByteArrayOp_Word8AsChar = 289-primOpTag IndexByteArrayOp_Word8AsWideChar = 290-primOpTag IndexByteArrayOp_Word8AsAddr = 291-primOpTag IndexByteArrayOp_Word8AsFloat = 292-primOpTag IndexByteArrayOp_Word8AsDouble = 293-primOpTag IndexByteArrayOp_Word8AsStablePtr = 294-primOpTag IndexByteArrayOp_Word8AsInt16 = 295-primOpTag IndexByteArrayOp_Word8AsInt32 = 296-primOpTag IndexByteArrayOp_Word8AsInt64 = 297-primOpTag IndexByteArrayOp_Word8AsInt = 298-primOpTag IndexByteArrayOp_Word8AsWord16 = 299-primOpTag IndexByteArrayOp_Word8AsWord32 = 300-primOpTag IndexByteArrayOp_Word8AsWord64 = 301-primOpTag IndexByteArrayOp_Word8AsWord = 302-primOpTag ReadByteArrayOp_Char = 303-primOpTag ReadByteArrayOp_WideChar = 304-primOpTag ReadByteArrayOp_Int = 305-primOpTag ReadByteArrayOp_Word = 306-primOpTag ReadByteArrayOp_Addr = 307-primOpTag ReadByteArrayOp_Float = 308-primOpTag ReadByteArrayOp_Double = 309-primOpTag ReadByteArrayOp_StablePtr = 310-primOpTag ReadByteArrayOp_Int8 = 311-primOpTag ReadByteArrayOp_Int16 = 312-primOpTag ReadByteArrayOp_Int32 = 313-primOpTag ReadByteArrayOp_Int64 = 314-primOpTag ReadByteArrayOp_Word8 = 315-primOpTag ReadByteArrayOp_Word16 = 316-primOpTag ReadByteArrayOp_Word32 = 317-primOpTag ReadByteArrayOp_Word64 = 318-primOpTag ReadByteArrayOp_Word8AsChar = 319-primOpTag ReadByteArrayOp_Word8AsWideChar = 320-primOpTag ReadByteArrayOp_Word8AsAddr = 321-primOpTag ReadByteArrayOp_Word8AsFloat = 322-primOpTag ReadByteArrayOp_Word8AsDouble = 323-primOpTag ReadByteArrayOp_Word8AsStablePtr = 324-primOpTag ReadByteArrayOp_Word8AsInt16 = 325-primOpTag ReadByteArrayOp_Word8AsInt32 = 326-primOpTag ReadByteArrayOp_Word8AsInt64 = 327-primOpTag ReadByteArrayOp_Word8AsInt = 328-primOpTag ReadByteArrayOp_Word8AsWord16 = 329-primOpTag ReadByteArrayOp_Word8AsWord32 = 330-primOpTag ReadByteArrayOp_Word8AsWord64 = 331-primOpTag ReadByteArrayOp_Word8AsWord = 332-primOpTag WriteByteArrayOp_Char = 333-primOpTag WriteByteArrayOp_WideChar = 334-primOpTag WriteByteArrayOp_Int = 335-primOpTag WriteByteArrayOp_Word = 336-primOpTag WriteByteArrayOp_Addr = 337-primOpTag WriteByteArrayOp_Float = 338-primOpTag WriteByteArrayOp_Double = 339-primOpTag WriteByteArrayOp_StablePtr = 340-primOpTag WriteByteArrayOp_Int8 = 341-primOpTag WriteByteArrayOp_Int16 = 342-primOpTag WriteByteArrayOp_Int32 = 343-primOpTag WriteByteArrayOp_Int64 = 344-primOpTag WriteByteArrayOp_Word8 = 345-primOpTag WriteByteArrayOp_Word16 = 346-primOpTag WriteByteArrayOp_Word32 = 347-primOpTag WriteByteArrayOp_Word64 = 348-primOpTag WriteByteArrayOp_Word8AsChar = 349-primOpTag WriteByteArrayOp_Word8AsWideChar = 350-primOpTag WriteByteArrayOp_Word8AsAddr = 351-primOpTag WriteByteArrayOp_Word8AsFloat = 352-primOpTag WriteByteArrayOp_Word8AsDouble = 353-primOpTag WriteByteArrayOp_Word8AsStablePtr = 354-primOpTag WriteByteArrayOp_Word8AsInt16 = 355-primOpTag WriteByteArrayOp_Word8AsInt32 = 356-primOpTag WriteByteArrayOp_Word8AsInt64 = 357-primOpTag WriteByteArrayOp_Word8AsInt = 358-primOpTag WriteByteArrayOp_Word8AsWord16 = 359-primOpTag WriteByteArrayOp_Word8AsWord32 = 360-primOpTag WriteByteArrayOp_Word8AsWord64 = 361-primOpTag WriteByteArrayOp_Word8AsWord = 362-primOpTag CompareByteArraysOp = 363-primOpTag CopyByteArrayOp = 364-primOpTag CopyMutableByteArrayOp = 365-primOpTag CopyByteArrayToAddrOp = 366-primOpTag CopyMutableByteArrayToAddrOp = 367-primOpTag CopyAddrToByteArrayOp = 368-primOpTag SetByteArrayOp = 369-primOpTag AtomicReadByteArrayOp_Int = 370-primOpTag AtomicWriteByteArrayOp_Int = 371-primOpTag CasByteArrayOp_Int = 372-primOpTag FetchAddByteArrayOp_Int = 373-primOpTag FetchSubByteArrayOp_Int = 374-primOpTag FetchAndByteArrayOp_Int = 375-primOpTag FetchNandByteArrayOp_Int = 376-primOpTag FetchOrByteArrayOp_Int = 377-primOpTag FetchXorByteArrayOp_Int = 378-primOpTag NewArrayArrayOp = 379-primOpTag SameMutableArrayArrayOp = 380-primOpTag UnsafeFreezeArrayArrayOp = 381-primOpTag SizeofArrayArrayOp = 382-primOpTag SizeofMutableArrayArrayOp = 383-primOpTag IndexArrayArrayOp_ByteArray = 384-primOpTag IndexArrayArrayOp_ArrayArray = 385-primOpTag ReadArrayArrayOp_ByteArray = 386-primOpTag ReadArrayArrayOp_MutableByteArray = 387-primOpTag ReadArrayArrayOp_ArrayArray = 388-primOpTag ReadArrayArrayOp_MutableArrayArray = 389-primOpTag WriteArrayArrayOp_ByteArray = 390-primOpTag WriteArrayArrayOp_MutableByteArray = 391-primOpTag WriteArrayArrayOp_ArrayArray = 392-primOpTag WriteArrayArrayOp_MutableArrayArray = 393-primOpTag CopyArrayArrayOp = 394-primOpTag CopyMutableArrayArrayOp = 395-primOpTag AddrAddOp = 396-primOpTag AddrSubOp = 397-primOpTag AddrRemOp = 398-primOpTag Addr2IntOp = 399-primOpTag Int2AddrOp = 400-primOpTag AddrGtOp = 401-primOpTag AddrGeOp = 402-primOpTag AddrEqOp = 403-primOpTag AddrNeOp = 404-primOpTag AddrLtOp = 405-primOpTag AddrLeOp = 406-primOpTag IndexOffAddrOp_Char = 407-primOpTag IndexOffAddrOp_WideChar = 408-primOpTag IndexOffAddrOp_Int = 409-primOpTag IndexOffAddrOp_Word = 410-primOpTag IndexOffAddrOp_Addr = 411-primOpTag IndexOffAddrOp_Float = 412-primOpTag IndexOffAddrOp_Double = 413-primOpTag IndexOffAddrOp_StablePtr = 414-primOpTag IndexOffAddrOp_Int8 = 415-primOpTag IndexOffAddrOp_Int16 = 416-primOpTag IndexOffAddrOp_Int32 = 417-primOpTag IndexOffAddrOp_Int64 = 418-primOpTag IndexOffAddrOp_Word8 = 419-primOpTag IndexOffAddrOp_Word16 = 420-primOpTag IndexOffAddrOp_Word32 = 421-primOpTag IndexOffAddrOp_Word64 = 422-primOpTag ReadOffAddrOp_Char = 423-primOpTag ReadOffAddrOp_WideChar = 424-primOpTag ReadOffAddrOp_Int = 425-primOpTag ReadOffAddrOp_Word = 426-primOpTag ReadOffAddrOp_Addr = 427-primOpTag ReadOffAddrOp_Float = 428-primOpTag ReadOffAddrOp_Double = 429-primOpTag ReadOffAddrOp_StablePtr = 430-primOpTag ReadOffAddrOp_Int8 = 431-primOpTag ReadOffAddrOp_Int16 = 432-primOpTag ReadOffAddrOp_Int32 = 433-primOpTag ReadOffAddrOp_Int64 = 434-primOpTag ReadOffAddrOp_Word8 = 435-primOpTag ReadOffAddrOp_Word16 = 436-primOpTag ReadOffAddrOp_Word32 = 437-primOpTag ReadOffAddrOp_Word64 = 438-primOpTag WriteOffAddrOp_Char = 439-primOpTag WriteOffAddrOp_WideChar = 440-primOpTag WriteOffAddrOp_Int = 441-primOpTag WriteOffAddrOp_Word = 442-primOpTag WriteOffAddrOp_Addr = 443-primOpTag WriteOffAddrOp_Float = 444-primOpTag WriteOffAddrOp_Double = 445-primOpTag WriteOffAddrOp_StablePtr = 446-primOpTag WriteOffAddrOp_Int8 = 447-primOpTag WriteOffAddrOp_Int16 = 448-primOpTag WriteOffAddrOp_Int32 = 449-primOpTag WriteOffAddrOp_Int64 = 450-primOpTag WriteOffAddrOp_Word8 = 451-primOpTag WriteOffAddrOp_Word16 = 452-primOpTag WriteOffAddrOp_Word32 = 453-primOpTag WriteOffAddrOp_Word64 = 454-primOpTag NewMutVarOp = 455-primOpTag ReadMutVarOp = 456-primOpTag WriteMutVarOp = 457-primOpTag SameMutVarOp = 458-primOpTag AtomicModifyMutVar2Op = 459-primOpTag AtomicModifyMutVar_Op = 460-primOpTag CasMutVarOp = 461-primOpTag CatchOp = 462-primOpTag RaiseOp = 463-primOpTag RaiseIOOp = 464-primOpTag MaskAsyncExceptionsOp = 465-primOpTag MaskUninterruptibleOp = 466-primOpTag UnmaskAsyncExceptionsOp = 467-primOpTag MaskStatus = 468-primOpTag AtomicallyOp = 469-primOpTag RetryOp = 470-primOpTag CatchRetryOp = 471-primOpTag CatchSTMOp = 472-primOpTag NewTVarOp = 473-primOpTag ReadTVarOp = 474-primOpTag ReadTVarIOOp = 475-primOpTag WriteTVarOp = 476-primOpTag SameTVarOp = 477-primOpTag NewMVarOp = 478-primOpTag TakeMVarOp = 479-primOpTag TryTakeMVarOp = 480-primOpTag PutMVarOp = 481-primOpTag TryPutMVarOp = 482-primOpTag ReadMVarOp = 483-primOpTag TryReadMVarOp = 484-primOpTag SameMVarOp = 485-primOpTag IsEmptyMVarOp = 486-primOpTag DelayOp = 487-primOpTag WaitReadOp = 488-primOpTag WaitWriteOp = 489-primOpTag ForkOp = 490-primOpTag ForkOnOp = 491-primOpTag KillThreadOp = 492-primOpTag YieldOp = 493-primOpTag MyThreadIdOp = 494-primOpTag LabelThreadOp = 495-primOpTag IsCurrentThreadBoundOp = 496-primOpTag NoDuplicateOp = 497-primOpTag ThreadStatusOp = 498-primOpTag MkWeakOp = 499-primOpTag MkWeakNoFinalizerOp = 500-primOpTag AddCFinalizerToWeakOp = 501-primOpTag DeRefWeakOp = 502-primOpTag FinalizeWeakOp = 503-primOpTag TouchOp = 504-primOpTag MakeStablePtrOp = 505-primOpTag DeRefStablePtrOp = 506-primOpTag EqStablePtrOp = 507-primOpTag MakeStableNameOp = 508-primOpTag EqStableNameOp = 509-primOpTag StableNameToIntOp = 510-primOpTag CompactNewOp = 511-primOpTag CompactResizeOp = 512-primOpTag CompactContainsOp = 513-primOpTag CompactContainsAnyOp = 514-primOpTag CompactGetFirstBlockOp = 515-primOpTag CompactGetNextBlockOp = 516-primOpTag CompactAllocateBlockOp = 517-primOpTag CompactFixupPointersOp = 518-primOpTag CompactAdd = 519-primOpTag CompactAddWithSharing = 520-primOpTag CompactSize = 521-primOpTag ReallyUnsafePtrEqualityOp = 522-primOpTag ParOp = 523-primOpTag SparkOp = 524-primOpTag SeqOp = 525-primOpTag GetSparkOp = 526-primOpTag NumSparks = 527-primOpTag DataToTagOp = 528-primOpTag TagToEnumOp = 529-primOpTag AddrToAnyOp = 530-primOpTag AnyToAddrOp = 531-primOpTag MkApUpd0_Op = 532-primOpTag NewBCOOp = 533-primOpTag UnpackClosureOp = 534-primOpTag ClosureSizeOp = 535-primOpTag GetApStackValOp = 536-primOpTag GetCCSOfOp = 537-primOpTag GetCurrentCCSOp = 538-primOpTag ClearCCSOp = 539-primOpTag TraceEventOp = 540-primOpTag TraceEventBinaryOp = 541-primOpTag TraceMarkerOp = 542-primOpTag SetThreadAllocationCounter = 543-primOpTag (VecBroadcastOp IntVec 16 W8) = 544-primOpTag (VecBroadcastOp IntVec 8 W16) = 545-primOpTag (VecBroadcastOp IntVec 4 W32) = 546-primOpTag (VecBroadcastOp IntVec 2 W64) = 547-primOpTag (VecBroadcastOp IntVec 32 W8) = 548-primOpTag (VecBroadcastOp IntVec 16 W16) = 549-primOpTag (VecBroadcastOp IntVec 8 W32) = 550-primOpTag (VecBroadcastOp IntVec 4 W64) = 551-primOpTag (VecBroadcastOp IntVec 64 W8) = 552-primOpTag (VecBroadcastOp IntVec 32 W16) = 553-primOpTag (VecBroadcastOp IntVec 16 W32) = 554-primOpTag (VecBroadcastOp IntVec 8 W64) = 555-primOpTag (VecBroadcastOp WordVec 16 W8) = 556-primOpTag (VecBroadcastOp WordVec 8 W16) = 557-primOpTag (VecBroadcastOp WordVec 4 W32) = 558-primOpTag (VecBroadcastOp WordVec 2 W64) = 559-primOpTag (VecBroadcastOp WordVec 32 W8) = 560-primOpTag (VecBroadcastOp WordVec 16 W16) = 561-primOpTag (VecBroadcastOp WordVec 8 W32) = 562-primOpTag (VecBroadcastOp WordVec 4 W64) = 563-primOpTag (VecBroadcastOp WordVec 64 W8) = 564-primOpTag (VecBroadcastOp WordVec 32 W16) = 565-primOpTag (VecBroadcastOp WordVec 16 W32) = 566-primOpTag (VecBroadcastOp WordVec 8 W64) = 567-primOpTag (VecBroadcastOp FloatVec 4 W32) = 568-primOpTag (VecBroadcastOp FloatVec 2 W64) = 569-primOpTag (VecBroadcastOp FloatVec 8 W32) = 570-primOpTag (VecBroadcastOp FloatVec 4 W64) = 571-primOpTag (VecBroadcastOp FloatVec 16 W32) = 572-primOpTag (VecBroadcastOp FloatVec 8 W64) = 573-primOpTag (VecPackOp IntVec 16 W8) = 574-primOpTag (VecPackOp IntVec 8 W16) = 575-primOpTag (VecPackOp IntVec 4 W32) = 576-primOpTag (VecPackOp IntVec 2 W64) = 577-primOpTag (VecPackOp IntVec 32 W8) = 578-primOpTag (VecPackOp IntVec 16 W16) = 579-primOpTag (VecPackOp IntVec 8 W32) = 580-primOpTag (VecPackOp IntVec 4 W64) = 581-primOpTag (VecPackOp IntVec 64 W8) = 582-primOpTag (VecPackOp IntVec 32 W16) = 583-primOpTag (VecPackOp IntVec 16 W32) = 584-primOpTag (VecPackOp IntVec 8 W64) = 585-primOpTag (VecPackOp WordVec 16 W8) = 586-primOpTag (VecPackOp WordVec 8 W16) = 587-primOpTag (VecPackOp WordVec 4 W32) = 588-primOpTag (VecPackOp WordVec 2 W64) = 589-primOpTag (VecPackOp WordVec 32 W8) = 590-primOpTag (VecPackOp WordVec 16 W16) = 591-primOpTag (VecPackOp WordVec 8 W32) = 592-primOpTag (VecPackOp WordVec 4 W64) = 593-primOpTag (VecPackOp WordVec 64 W8) = 594-primOpTag (VecPackOp WordVec 32 W16) = 595-primOpTag (VecPackOp WordVec 16 W32) = 596-primOpTag (VecPackOp WordVec 8 W64) = 597-primOpTag (VecPackOp FloatVec 4 W32) = 598-primOpTag (VecPackOp FloatVec 2 W64) = 599-primOpTag (VecPackOp FloatVec 8 W32) = 600-primOpTag (VecPackOp FloatVec 4 W64) = 601-primOpTag (VecPackOp FloatVec 16 W32) = 602-primOpTag (VecPackOp FloatVec 8 W64) = 603-primOpTag (VecUnpackOp IntVec 16 W8) = 604-primOpTag (VecUnpackOp IntVec 8 W16) = 605-primOpTag (VecUnpackOp IntVec 4 W32) = 606-primOpTag (VecUnpackOp IntVec 2 W64) = 607-primOpTag (VecUnpackOp IntVec 32 W8) = 608-primOpTag (VecUnpackOp IntVec 16 W16) = 609-primOpTag (VecUnpackOp IntVec 8 W32) = 610-primOpTag (VecUnpackOp IntVec 4 W64) = 611-primOpTag (VecUnpackOp IntVec 64 W8) = 612-primOpTag (VecUnpackOp IntVec 32 W16) = 613-primOpTag (VecUnpackOp IntVec 16 W32) = 614-primOpTag (VecUnpackOp IntVec 8 W64) = 615-primOpTag (VecUnpackOp WordVec 16 W8) = 616-primOpTag (VecUnpackOp WordVec 8 W16) = 617-primOpTag (VecUnpackOp WordVec 4 W32) = 618-primOpTag (VecUnpackOp WordVec 2 W64) = 619-primOpTag (VecUnpackOp WordVec 32 W8) = 620-primOpTag (VecUnpackOp WordVec 16 W16) = 621-primOpTag (VecUnpackOp WordVec 8 W32) = 622-primOpTag (VecUnpackOp WordVec 4 W64) = 623-primOpTag (VecUnpackOp WordVec 64 W8) = 624-primOpTag (VecUnpackOp WordVec 32 W16) = 625-primOpTag (VecUnpackOp WordVec 16 W32) = 626-primOpTag (VecUnpackOp WordVec 8 W64) = 627-primOpTag (VecUnpackOp FloatVec 4 W32) = 628-primOpTag (VecUnpackOp FloatVec 2 W64) = 629-primOpTag (VecUnpackOp FloatVec 8 W32) = 630-primOpTag (VecUnpackOp FloatVec 4 W64) = 631-primOpTag (VecUnpackOp FloatVec 16 W32) = 632-primOpTag (VecUnpackOp FloatVec 8 W64) = 633-primOpTag (VecInsertOp IntVec 16 W8) = 634-primOpTag (VecInsertOp IntVec 8 W16) = 635-primOpTag (VecInsertOp IntVec 4 W32) = 636-primOpTag (VecInsertOp IntVec 2 W64) = 637-primOpTag (VecInsertOp IntVec 32 W8) = 638-primOpTag (VecInsertOp IntVec 16 W16) = 639-primOpTag (VecInsertOp IntVec 8 W32) = 640-primOpTag (VecInsertOp IntVec 4 W64) = 641-primOpTag (VecInsertOp IntVec 64 W8) = 642-primOpTag (VecInsertOp IntVec 32 W16) = 643-primOpTag (VecInsertOp IntVec 16 W32) = 644-primOpTag (VecInsertOp IntVec 8 W64) = 645-primOpTag (VecInsertOp WordVec 16 W8) = 646-primOpTag (VecInsertOp WordVec 8 W16) = 647-primOpTag (VecInsertOp WordVec 4 W32) = 648-primOpTag (VecInsertOp WordVec 2 W64) = 649-primOpTag (VecInsertOp WordVec 32 W8) = 650-primOpTag (VecInsertOp WordVec 16 W16) = 651-primOpTag (VecInsertOp WordVec 8 W32) = 652-primOpTag (VecInsertOp WordVec 4 W64) = 653-primOpTag (VecInsertOp WordVec 64 W8) = 654-primOpTag (VecInsertOp WordVec 32 W16) = 655-primOpTag (VecInsertOp WordVec 16 W32) = 656-primOpTag (VecInsertOp WordVec 8 W64) = 657-primOpTag (VecInsertOp FloatVec 4 W32) = 658-primOpTag (VecInsertOp FloatVec 2 W64) = 659-primOpTag (VecInsertOp FloatVec 8 W32) = 660-primOpTag (VecInsertOp FloatVec 4 W64) = 661-primOpTag (VecInsertOp FloatVec 16 W32) = 662-primOpTag (VecInsertOp FloatVec 8 W64) = 663-primOpTag (VecAddOp IntVec 16 W8) = 664-primOpTag (VecAddOp IntVec 8 W16) = 665-primOpTag (VecAddOp IntVec 4 W32) = 666-primOpTag (VecAddOp IntVec 2 W64) = 667-primOpTag (VecAddOp IntVec 32 W8) = 668-primOpTag (VecAddOp IntVec 16 W16) = 669-primOpTag (VecAddOp IntVec 8 W32) = 670-primOpTag (VecAddOp IntVec 4 W64) = 671-primOpTag (VecAddOp IntVec 64 W8) = 672-primOpTag (VecAddOp IntVec 32 W16) = 673-primOpTag (VecAddOp IntVec 16 W32) = 674-primOpTag (VecAddOp IntVec 8 W64) = 675-primOpTag (VecAddOp WordVec 16 W8) = 676-primOpTag (VecAddOp WordVec 8 W16) = 677-primOpTag (VecAddOp WordVec 4 W32) = 678-primOpTag (VecAddOp WordVec 2 W64) = 679-primOpTag (VecAddOp WordVec 32 W8) = 680-primOpTag (VecAddOp WordVec 16 W16) = 681-primOpTag (VecAddOp WordVec 8 W32) = 682-primOpTag (VecAddOp WordVec 4 W64) = 683-primOpTag (VecAddOp WordVec 64 W8) = 684-primOpTag (VecAddOp WordVec 32 W16) = 685-primOpTag (VecAddOp WordVec 16 W32) = 686-primOpTag (VecAddOp WordVec 8 W64) = 687-primOpTag (VecAddOp FloatVec 4 W32) = 688-primOpTag (VecAddOp FloatVec 2 W64) = 689-primOpTag (VecAddOp FloatVec 8 W32) = 690-primOpTag (VecAddOp FloatVec 4 W64) = 691-primOpTag (VecAddOp FloatVec 16 W32) = 692-primOpTag (VecAddOp FloatVec 8 W64) = 693-primOpTag (VecSubOp IntVec 16 W8) = 694-primOpTag (VecSubOp IntVec 8 W16) = 695-primOpTag (VecSubOp IntVec 4 W32) = 696-primOpTag (VecSubOp IntVec 2 W64) = 697-primOpTag (VecSubOp IntVec 32 W8) = 698-primOpTag (VecSubOp IntVec 16 W16) = 699-primOpTag (VecSubOp IntVec 8 W32) = 700-primOpTag (VecSubOp IntVec 4 W64) = 701-primOpTag (VecSubOp IntVec 64 W8) = 702-primOpTag (VecSubOp IntVec 32 W16) = 703-primOpTag (VecSubOp IntVec 16 W32) = 704-primOpTag (VecSubOp IntVec 8 W64) = 705-primOpTag (VecSubOp WordVec 16 W8) = 706-primOpTag (VecSubOp WordVec 8 W16) = 707-primOpTag (VecSubOp WordVec 4 W32) = 708-primOpTag (VecSubOp WordVec 2 W64) = 709-primOpTag (VecSubOp WordVec 32 W8) = 710-primOpTag (VecSubOp WordVec 16 W16) = 711-primOpTag (VecSubOp WordVec 8 W32) = 712-primOpTag (VecSubOp WordVec 4 W64) = 713-primOpTag (VecSubOp WordVec 64 W8) = 714-primOpTag (VecSubOp WordVec 32 W16) = 715-primOpTag (VecSubOp WordVec 16 W32) = 716-primOpTag (VecSubOp WordVec 8 W64) = 717-primOpTag (VecSubOp FloatVec 4 W32) = 718-primOpTag (VecSubOp FloatVec 2 W64) = 719-primOpTag (VecSubOp FloatVec 8 W32) = 720-primOpTag (VecSubOp FloatVec 4 W64) = 721-primOpTag (VecSubOp FloatVec 16 W32) = 722-primOpTag (VecSubOp FloatVec 8 W64) = 723-primOpTag (VecMulOp IntVec 16 W8) = 724-primOpTag (VecMulOp IntVec 8 W16) = 725-primOpTag (VecMulOp IntVec 4 W32) = 726-primOpTag (VecMulOp IntVec 2 W64) = 727-primOpTag (VecMulOp IntVec 32 W8) = 728-primOpTag (VecMulOp IntVec 16 W16) = 729-primOpTag (VecMulOp IntVec 8 W32) = 730-primOpTag (VecMulOp IntVec 4 W64) = 731-primOpTag (VecMulOp IntVec 64 W8) = 732-primOpTag (VecMulOp IntVec 32 W16) = 733-primOpTag (VecMulOp IntVec 16 W32) = 734-primOpTag (VecMulOp IntVec 8 W64) = 735-primOpTag (VecMulOp WordVec 16 W8) = 736-primOpTag (VecMulOp WordVec 8 W16) = 737-primOpTag (VecMulOp WordVec 4 W32) = 738-primOpTag (VecMulOp WordVec 2 W64) = 739-primOpTag (VecMulOp WordVec 32 W8) = 740-primOpTag (VecMulOp WordVec 16 W16) = 741-primOpTag (VecMulOp WordVec 8 W32) = 742-primOpTag (VecMulOp WordVec 4 W64) = 743-primOpTag (VecMulOp WordVec 64 W8) = 744-primOpTag (VecMulOp WordVec 32 W16) = 745-primOpTag (VecMulOp WordVec 16 W32) = 746-primOpTag (VecMulOp WordVec 8 W64) = 747-primOpTag (VecMulOp FloatVec 4 W32) = 748-primOpTag (VecMulOp FloatVec 2 W64) = 749-primOpTag (VecMulOp FloatVec 8 W32) = 750-primOpTag (VecMulOp FloatVec 4 W64) = 751-primOpTag (VecMulOp FloatVec 16 W32) = 752-primOpTag (VecMulOp FloatVec 8 W64) = 753-primOpTag (VecDivOp FloatVec 4 W32) = 754-primOpTag (VecDivOp FloatVec 2 W64) = 755-primOpTag (VecDivOp FloatVec 8 W32) = 756-primOpTag (VecDivOp FloatVec 4 W64) = 757-primOpTag (VecDivOp FloatVec 16 W32) = 758-primOpTag (VecDivOp FloatVec 8 W64) = 759-primOpTag (VecQuotOp IntVec 16 W8) = 760-primOpTag (VecQuotOp IntVec 8 W16) = 761-primOpTag (VecQuotOp IntVec 4 W32) = 762-primOpTag (VecQuotOp IntVec 2 W64) = 763-primOpTag (VecQuotOp IntVec 32 W8) = 764-primOpTag (VecQuotOp IntVec 16 W16) = 765-primOpTag (VecQuotOp IntVec 8 W32) = 766-primOpTag (VecQuotOp IntVec 4 W64) = 767-primOpTag (VecQuotOp IntVec 64 W8) = 768-primOpTag (VecQuotOp IntVec 32 W16) = 769-primOpTag (VecQuotOp IntVec 16 W32) = 770-primOpTag (VecQuotOp IntVec 8 W64) = 771-primOpTag (VecQuotOp WordVec 16 W8) = 772-primOpTag (VecQuotOp WordVec 8 W16) = 773-primOpTag (VecQuotOp WordVec 4 W32) = 774-primOpTag (VecQuotOp WordVec 2 W64) = 775-primOpTag (VecQuotOp WordVec 32 W8) = 776-primOpTag (VecQuotOp WordVec 16 W16) = 777-primOpTag (VecQuotOp WordVec 8 W32) = 778-primOpTag (VecQuotOp WordVec 4 W64) = 779-primOpTag (VecQuotOp WordVec 64 W8) = 780-primOpTag (VecQuotOp WordVec 32 W16) = 781-primOpTag (VecQuotOp WordVec 16 W32) = 782-primOpTag (VecQuotOp WordVec 8 W64) = 783-primOpTag (VecRemOp IntVec 16 W8) = 784-primOpTag (VecRemOp IntVec 8 W16) = 785-primOpTag (VecRemOp IntVec 4 W32) = 786-primOpTag (VecRemOp IntVec 2 W64) = 787-primOpTag (VecRemOp IntVec 32 W8) = 788-primOpTag (VecRemOp IntVec 16 W16) = 789-primOpTag (VecRemOp IntVec 8 W32) = 790-primOpTag (VecRemOp IntVec 4 W64) = 791-primOpTag (VecRemOp IntVec 64 W8) = 792-primOpTag (VecRemOp IntVec 32 W16) = 793-primOpTag (VecRemOp IntVec 16 W32) = 794-primOpTag (VecRemOp IntVec 8 W64) = 795-primOpTag (VecRemOp WordVec 16 W8) = 796-primOpTag (VecRemOp WordVec 8 W16) = 797-primOpTag (VecRemOp WordVec 4 W32) = 798-primOpTag (VecRemOp WordVec 2 W64) = 799-primOpTag (VecRemOp WordVec 32 W8) = 800-primOpTag (VecRemOp WordVec 16 W16) = 801-primOpTag (VecRemOp WordVec 8 W32) = 802-primOpTag (VecRemOp WordVec 4 W64) = 803-primOpTag (VecRemOp WordVec 64 W8) = 804-primOpTag (VecRemOp WordVec 32 W16) = 805-primOpTag (VecRemOp WordVec 16 W32) = 806-primOpTag (VecRemOp WordVec 8 W64) = 807-primOpTag (VecNegOp IntVec 16 W8) = 808-primOpTag (VecNegOp IntVec 8 W16) = 809-primOpTag (VecNegOp IntVec 4 W32) = 810-primOpTag (VecNegOp IntVec 2 W64) = 811-primOpTag (VecNegOp IntVec 32 W8) = 812-primOpTag (VecNegOp IntVec 16 W16) = 813-primOpTag (VecNegOp IntVec 8 W32) = 814-primOpTag (VecNegOp IntVec 4 W64) = 815-primOpTag (VecNegOp IntVec 64 W8) = 816-primOpTag (VecNegOp IntVec 32 W16) = 817-primOpTag (VecNegOp IntVec 16 W32) = 818-primOpTag (VecNegOp IntVec 8 W64) = 819-primOpTag (VecNegOp FloatVec 4 W32) = 820-primOpTag (VecNegOp FloatVec 2 W64) = 821-primOpTag (VecNegOp FloatVec 8 W32) = 822-primOpTag (VecNegOp FloatVec 4 W64) = 823-primOpTag (VecNegOp FloatVec 16 W32) = 824-primOpTag (VecNegOp FloatVec 8 W64) = 825-primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 826-primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 827-primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 828-primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 829-primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 830-primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 831-primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 832-primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 833-primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 834-primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 835-primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 836-primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 837-primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 838-primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 839-primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 840-primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 841-primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 842-primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 843-primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 844-primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 845-primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 846-primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 847-primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 848-primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 849-primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 850-primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 851-primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 852-primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 853-primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 854-primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 855-primOpTag (VecReadByteArrayOp IntVec 16 W8) = 856-primOpTag (VecReadByteArrayOp IntVec 8 W16) = 857-primOpTag (VecReadByteArrayOp IntVec 4 W32) = 858-primOpTag (VecReadByteArrayOp IntVec 2 W64) = 859-primOpTag (VecReadByteArrayOp IntVec 32 W8) = 860-primOpTag (VecReadByteArrayOp IntVec 16 W16) = 861-primOpTag (VecReadByteArrayOp IntVec 8 W32) = 862-primOpTag (VecReadByteArrayOp IntVec 4 W64) = 863-primOpTag (VecReadByteArrayOp IntVec 64 W8) = 864-primOpTag (VecReadByteArrayOp IntVec 32 W16) = 865-primOpTag (VecReadByteArrayOp IntVec 16 W32) = 866-primOpTag (VecReadByteArrayOp IntVec 8 W64) = 867-primOpTag (VecReadByteArrayOp WordVec 16 W8) = 868-primOpTag (VecReadByteArrayOp WordVec 8 W16) = 869-primOpTag (VecReadByteArrayOp WordVec 4 W32) = 870-primOpTag (VecReadByteArrayOp WordVec 2 W64) = 871-primOpTag (VecReadByteArrayOp WordVec 32 W8) = 872-primOpTag (VecReadByteArrayOp WordVec 16 W16) = 873-primOpTag (VecReadByteArrayOp WordVec 8 W32) = 874-primOpTag (VecReadByteArrayOp WordVec 4 W64) = 875-primOpTag (VecReadByteArrayOp WordVec 64 W8) = 876-primOpTag (VecReadByteArrayOp WordVec 32 W16) = 877-primOpTag (VecReadByteArrayOp WordVec 16 W32) = 878-primOpTag (VecReadByteArrayOp WordVec 8 W64) = 879-primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 880-primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 881-primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 882-primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 883-primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 884-primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 885-primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 886-primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 887-primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 888-primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 889-primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 890-primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 891-primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 892-primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 893-primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 894-primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 895-primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 896-primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 897-primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 898-primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 899-primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 900-primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 901-primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 902-primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 903-primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 904-primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 905-primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 906-primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 907-primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 908-primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 909-primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 910-primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 911-primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 912-primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 913-primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 914-primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 915-primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 916-primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 917-primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 918-primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 919-primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 920-primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 921-primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 922-primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 923-primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 924-primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 925-primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 926-primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 927-primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 928-primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 929-primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 930-primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 931-primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 932-primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 933-primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 934-primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 935-primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 936-primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 937-primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 938-primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 939-primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 940-primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 941-primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 942-primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 943-primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 944-primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 945-primOpTag (VecReadOffAddrOp IntVec 16 W8) = 946-primOpTag (VecReadOffAddrOp IntVec 8 W16) = 947-primOpTag (VecReadOffAddrOp IntVec 4 W32) = 948-primOpTag (VecReadOffAddrOp IntVec 2 W64) = 949-primOpTag (VecReadOffAddrOp IntVec 32 W8) = 950-primOpTag (VecReadOffAddrOp IntVec 16 W16) = 951-primOpTag (VecReadOffAddrOp IntVec 8 W32) = 952-primOpTag (VecReadOffAddrOp IntVec 4 W64) = 953-primOpTag (VecReadOffAddrOp IntVec 64 W8) = 954-primOpTag (VecReadOffAddrOp IntVec 32 W16) = 955-primOpTag (VecReadOffAddrOp IntVec 16 W32) = 956-primOpTag (VecReadOffAddrOp IntVec 8 W64) = 957-primOpTag (VecReadOffAddrOp WordVec 16 W8) = 958-primOpTag (VecReadOffAddrOp WordVec 8 W16) = 959-primOpTag (VecReadOffAddrOp WordVec 4 W32) = 960-primOpTag (VecReadOffAddrOp WordVec 2 W64) = 961-primOpTag (VecReadOffAddrOp WordVec 32 W8) = 962-primOpTag (VecReadOffAddrOp WordVec 16 W16) = 963-primOpTag (VecReadOffAddrOp WordVec 8 W32) = 964-primOpTag (VecReadOffAddrOp WordVec 4 W64) = 965-primOpTag (VecReadOffAddrOp WordVec 64 W8) = 966-primOpTag (VecReadOffAddrOp WordVec 32 W16) = 967-primOpTag (VecReadOffAddrOp WordVec 16 W32) = 968-primOpTag (VecReadOffAddrOp WordVec 8 W64) = 969-primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 970-primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 971-primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 972-primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 973-primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 974-primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 975-primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 976-primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 977-primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 978-primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 979-primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 980-primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 981-primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 982-primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 983-primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 984-primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 985-primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 986-primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 987-primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 988-primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 989-primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 990-primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 991-primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 992-primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 993-primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 994-primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 995-primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 996-primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 997-primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 998-primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 999-primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1000-primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1001-primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1002-primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1003-primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1004-primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1005-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1006-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1007-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1008-primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1009-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1010-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1011-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1012-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1013-primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1014-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1015-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1016-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1017-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1018-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1019-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1020-primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1021-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1022-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1023-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1024-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1025-primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1026-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1027-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1028-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1029-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1030-primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1031-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1032-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1033-primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1034-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1035-primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1036-primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1037-primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1038-primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1039-primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1040-primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1041-primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1042-primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1043-primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1044-primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1045-primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1046-primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1047-primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1048-primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1049-primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1050-primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1051-primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1052-primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1053-primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1054-primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1055-primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1056-primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1057-primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1058-primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1059-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1060-primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1061-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1062-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1063-primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1064-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1065-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1066-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1067-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1068-primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1069-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1070-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1071-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1072-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1073-primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1074-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1075-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1076-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1077-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1078-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1079-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1080-primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1081-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1082-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1083-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1084-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1085-primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1086-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1087-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1088-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1089-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1090-primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1091-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1092-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1093-primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1094-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1095-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1096-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1097-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1098-primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1099-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1100-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1101-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1102-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1103-primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1104-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1105-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1106-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1107-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1108-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1109-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1110-primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1111-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1112-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1113-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1114-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1115-primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1116-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1117-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1118-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1119-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1120-primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1121-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1122-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1123-primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1124-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1125-primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1126-primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1127-primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1128-primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1129-primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1130-primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1131-primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1132-primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1133-primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1134-primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1135-primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1136-primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1137-primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1138-primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1139-primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1140-primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1141-primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1142-primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1143-primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1144-primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1145-primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1146-primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1147-primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1148-primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1149-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1150-primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1151-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1152-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1153-primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1154-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1155-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1156-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1157-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1158-primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1159-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1160-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1161-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1162-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1163-primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1164-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1165-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1166-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1167-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1168-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1169-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1170-primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1171-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1172-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1173-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1174-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1175-primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1176-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1177-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1178-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1179-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1180-primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1181-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1182-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1183-primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1184-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1185-primOpTag PrefetchByteArrayOp3 = 1186-primOpTag PrefetchMutableByteArrayOp3 = 1187-primOpTag PrefetchAddrOp3 = 1188-primOpTag PrefetchValueOp3 = 1189-primOpTag PrefetchByteArrayOp2 = 1190-primOpTag PrefetchMutableByteArrayOp2 = 1191-primOpTag PrefetchAddrOp2 = 1192-primOpTag PrefetchValueOp2 = 1193-primOpTag PrefetchByteArrayOp1 = 1194-primOpTag PrefetchMutableByteArrayOp1 = 1195-primOpTag PrefetchAddrOp1 = 1196-primOpTag PrefetchValueOp1 = 1197-primOpTag PrefetchByteArrayOp0 = 1198-primOpTag PrefetchMutableByteArrayOp0 = 1199-primOpTag PrefetchAddrOp0 = 1200-primOpTag PrefetchValueOp0 = 1201+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,542 @@+#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 $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 <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 (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 */+#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,19 @@+#if !defined(__GHCVERSION_H__)+#define __GHCVERSION_H__++#if !defined(__GLASGOW_HASKELL__)+# define __GLASGOW_HASKELL__ 809+#endif++#define __GLASGOW_HASKELL_PATCHLEVEL1__ 0+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20191027++#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
@@ -2,24 +2,38 @@ ,("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"))+,("arm-unknown-linux-musleabihf", ("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"))+,("armv6-unknown-linux-musleabihf", ("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"))+,("armv6l-unknown-linux-musleabihf", ("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", ""))+,("armv7-unknown-linux-musleabihf", ("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-musleabi", ("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", ""))+,("armv7a-unknown-linux-musleabihf", ("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-musleabi", ("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", ""))+,("armv7l-unknown-linux-musleabihf", ("e-m:e-p:32:32-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", "")) ,("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", ""))+,("powerpc64le-unknown-linux-gnu", ("e-m:e-i64:64-n32:64", "ppc64le", ""))+,("powerpc64le-unknown-linux-musl", ("e-m:e-i64:64-n32:64", "ppc64le", "")) ,("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"))+,("armv6-unknown-freebsd", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))+,("armv7-unknown-freebsd", ("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")) ]
+ 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
@@ -344,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@@ -630,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
includes/MachDeps.h view
@@ -25,7 +25,7 @@  * 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)@@ -36,9 +36,8 @@  *    wORD_SIZE :: DynFlags -> Int  *    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  */-#if !defined(STAGE) || STAGE >= 2  /* Sizes of C types come from here... */ #include "ghcautoconf.h"@@ -120,4 +119,3 @@  #define TAG_MASK ((1 << TAG_BITS) - 1) -#endif /* !defined(STAGE) || STAGE >= 2 */
+ includes/stg/MachRegs.h view
@@ -0,0 +1,774 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2014+ *+ * Registers used in STG code.  Might or might not correspond to+ * actual machine registers.+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++/* This file is #included into Haskell code in the compiler: #defines+ * only in here please.+ */++/*+ * Undefine these as a precaution: some of them were found to be+ * defined by system headers on ARM/Linux.+ */+#undef REG_R1+#undef REG_R2+#undef REG_R3+#undef REG_R4+#undef REG_R5+#undef REG_R6+#undef REG_R7+#undef REG_R8+#undef REG_R9+#undef REG_R10++/*+ * Defining MACHREGS_NO_REGS to 1 causes no global registers to be used.+ * MACHREGS_NO_REGS is typically controlled by NO_REGS, which is+ * typically defined by GHC, via a command-line option passed to gcc,+ * when the -funregisterised flag is given.+ *+ * NB. When MACHREGS_NO_REGS to 1, calling & return conventions may be+ * different.  For example, all function arguments will be passed on+ * the stack, and components of an unboxed tuple will be returned on+ * the stack rather than in registers.+ */+#if MACHREGS_NO_REGS == 1++/* Nothing */++#elif MACHREGS_NO_REGS == 0++/* ----------------------------------------------------------------------------+   Caller saves and callee-saves regs.++   Caller-saves regs have to be saved around C-calls made from STG+   land, so this file defines CALLER_SAVES_<reg> for each <reg> that+   is designated caller-saves in that machine's C calling convention.++   As it stands, the only registers that are ever marked caller saves+   are the RX, FX, DX and USER registers; as a result, if you+   decide to caller save a system register (e.g. SP, HP, etc), note that+   this code path is completely untested! -- EZY+   -------------------------------------------------------------------------- */++/* -----------------------------------------------------------------------------+   The x86 register mapping++   Ok, we've only got 6 general purpose registers, a frame pointer and a+   stack pointer.  \tr{%eax} and \tr{%edx} are return values from C functions,+   hence they get trashed across ccalls and are caller saves. \tr{%ebx},+   \tr{%esi}, \tr{%edi}, \tr{%ebp} are all callee-saves.++   Reg     STG-Reg+   ---------------+   ebx     Base+   ebp     Sp+   esi     R1+   edi     Hp++   Leaving SpLim out of the picture.+   -------------------------------------------------------------------------- */++#if defined(MACHREGS_i386)++#define REG(x) __asm__("%" #x)++#if !defined(not_doing_dynamic_linking)+#define REG_Base    ebx+#endif+#define REG_Sp      ebp++#if !defined(STOLEN_X86_REGS)+#define STOLEN_X86_REGS 4+#endif++#if STOLEN_X86_REGS >= 3+# define REG_R1     esi+#endif++#if STOLEN_X86_REGS >= 4+# define REG_Hp     edi+#endif+#define REG_MachSp  esp++#define REG_XMM1    xmm0+#define REG_XMM2    xmm1+#define REG_XMM3    xmm2+#define REG_XMM4    xmm3++#define REG_YMM1    ymm0+#define REG_YMM2    ymm1+#define REG_YMM3    ymm2+#define REG_YMM4    ymm3++#define REG_ZMM1    zmm0+#define REG_ZMM2    zmm1+#define REG_ZMM3    zmm2+#define REG_ZMM4    zmm3++#define MAX_REAL_VANILLA_REG 1  /* always, since it defines the entry conv */+#define MAX_REAL_FLOAT_REG   0+#define MAX_REAL_DOUBLE_REG  0+#define MAX_REAL_LONG_REG    0+#define MAX_REAL_XMM_REG     4+#define MAX_REAL_YMM_REG     4+#define MAX_REAL_ZMM_REG     4++/* -----------------------------------------------------------------------------+  The x86-64 register mapping++  %rax          caller-saves, don't steal this one+  %rbx          YES+  %rcx          arg reg, caller-saves+  %rdx          arg reg, caller-saves+  %rsi          arg reg, caller-saves+  %rdi          arg reg, caller-saves+  %rbp          YES (our *prime* register)+  %rsp          (unavailable - stack pointer)+  %r8           arg reg, caller-saves+  %r9           arg reg, caller-saves+  %r10          caller-saves+  %r11          caller-saves+  %r12          YES+  %r13          YES+  %r14          YES+  %r15          YES++  %xmm0-7       arg regs, caller-saves+  %xmm8-15      caller-saves++  Use the caller-saves regs for Rn, because we don't always have to+  save those (as opposed to Sp/Hp/SpLim etc. which always have to be+  saved).++  --------------------------------------------------------------------------- */++#elif defined(MACHREGS_x86_64)++#define REG(x) __asm__("%" #x)++#define REG_Base  r13+#define REG_Sp    rbp+#define REG_Hp    r12+#define REG_R1    rbx+#define REG_R2    r14+#define REG_R3    rsi+#define REG_R4    rdi+#define REG_R5    r8+#define REG_R6    r9+#define REG_SpLim r15+#define REG_MachSp  rsp++/*+Map both Fn and Dn to register xmmn so that we can pass a function any+combination of up to six Float# or Double# arguments without touching+the stack. See Note [Overlapping global registers] for implications.+*/++#define REG_F1    xmm1+#define REG_F2    xmm2+#define REG_F3    xmm3+#define REG_F4    xmm4+#define REG_F5    xmm5+#define REG_F6    xmm6++#define REG_D1    xmm1+#define REG_D2    xmm2+#define REG_D3    xmm3+#define REG_D4    xmm4+#define REG_D5    xmm5+#define REG_D6    xmm6++#define REG_XMM1    xmm1+#define REG_XMM2    xmm2+#define REG_XMM3    xmm3+#define REG_XMM4    xmm4+#define REG_XMM5    xmm5+#define REG_XMM6    xmm6++#define REG_YMM1    ymm1+#define REG_YMM2    ymm2+#define REG_YMM3    ymm3+#define REG_YMM4    ymm4+#define REG_YMM5    ymm5+#define REG_YMM6    ymm6++#define REG_ZMM1    zmm1+#define REG_ZMM2    zmm2+#define REG_ZMM3    zmm3+#define REG_ZMM4    zmm4+#define REG_ZMM5    zmm5+#define REG_ZMM6    zmm6++#if !defined(mingw32_HOST_OS)+#define CALLER_SAVES_R3+#define CALLER_SAVES_R4+#endif+#define CALLER_SAVES_R5+#define CALLER_SAVES_R6++#define CALLER_SAVES_F1+#define CALLER_SAVES_F2+#define CALLER_SAVES_F3+#define CALLER_SAVES_F4+#define CALLER_SAVES_F5+#if !defined(mingw32_HOST_OS)+#define CALLER_SAVES_F6+#endif++#define CALLER_SAVES_D1+#define CALLER_SAVES_D2+#define CALLER_SAVES_D3+#define CALLER_SAVES_D4+#define CALLER_SAVES_D5+#if !defined(mingw32_HOST_OS)+#define CALLER_SAVES_D6+#endif++#define CALLER_SAVES_XMM1+#define CALLER_SAVES_XMM2+#define CALLER_SAVES_XMM3+#define CALLER_SAVES_XMM4+#define CALLER_SAVES_XMM5+#if !defined(mingw32_HOST_OS)+#define CALLER_SAVES_XMM6+#endif++#define CALLER_SAVES_YMM1+#define CALLER_SAVES_YMM2+#define CALLER_SAVES_YMM3+#define CALLER_SAVES_YMM4+#define CALLER_SAVES_YMM5+#if !defined(mingw32_HOST_OS)+#define CALLER_SAVES_YMM6+#endif++#define CALLER_SAVES_ZMM1+#define CALLER_SAVES_ZMM2+#define CALLER_SAVES_ZMM3+#define CALLER_SAVES_ZMM4+#define CALLER_SAVES_ZMM5+#if !defined(mingw32_HOST_OS)+#define CALLER_SAVES_ZMM6+#endif++#define MAX_REAL_VANILLA_REG 6+#define MAX_REAL_FLOAT_REG   6+#define MAX_REAL_DOUBLE_REG  6+#define MAX_REAL_LONG_REG    0+#define MAX_REAL_XMM_REG     6+#define MAX_REAL_YMM_REG     6+#define MAX_REAL_ZMM_REG     6++/* -----------------------------------------------------------------------------+   The PowerPC register mapping++   0            system glue?    (caller-save, volatile)+   1            SP              (callee-save, non-volatile)+   2            AIX, powerpc64-linux:+                    RTOC        (a strange special case)+                powerpc32-linux:+                                reserved for use by system++   3-10         args/return     (caller-save, volatile)+   11,12        system glue?    (caller-save, volatile)+   13           on 64-bit:      reserved for thread state pointer+                on 32-bit:      (callee-save, non-volatile)+   14-31                        (callee-save, non-volatile)++   f0                           (caller-save, volatile)+   f1-f13       args/return     (caller-save, volatile)+   f14-f31                      (callee-save, non-volatile)++   \tr{14}--\tr{31} are wonderful callee-save registers on all ppc OSes.+   \tr{0}--\tr{12} are caller-save registers.++   \tr{%f14}--\tr{%f31} are callee-save floating-point registers.++   We can do the Whole Business with callee-save registers only!+   -------------------------------------------------------------------------- */++#elif defined(MACHREGS_powerpc)++#define REG(x) __asm__(#x)++#define REG_R1          r14+#define REG_R2          r15+#define REG_R3          r16+#define REG_R4          r17+#define REG_R5          r18+#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+#define REG_F3          fr16+#define REG_F4          fr17+#define REG_F5          fr18+#define REG_F6          fr19++#define REG_D1          fr20+#define REG_D2          fr21+#define REG_D3          fr22+#define REG_D4          fr23+#define REG_D5          fr24+#define REG_D6          fr25++#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++   !! IMPORTANT: if you change this register mapping you must also update+                 compiler/nativeGen/SPARC/Regs.hs. That file handles the+                 mapping for the NCG. This one only affects via-c code.++   The SPARC register (window) story: Remember, within the Haskell+   Threaded World, we essentially ``shut down'' the register-window+   mechanism---the window doesn't move at all while in this World.  It+   *does* move, of course, if we call out to arbitrary~C...++   The %i, %l, and %o registers (8 each) are the input, local, and+   output registers visible in one register window.  The 8 %g (global)+   registers are visible all the time.++      zero: always zero+   scratch: volatile across C-fn calls. used by linker.+       app: usable by application+    system: reserved for system++     alloc: allocated to in the register allocator, intra-closure only++                GHC usage     v8 ABI        v9 ABI+   Global+     %g0        zero        zero          zero+     %g1        alloc       scratch       scrach+     %g2        alloc       app           app+     %g3        alloc       app           app+     %g4        alloc       app           scratch+     %g5                    system        scratch+     %g6                    system        system+     %g7                    system        system++   Output: can be zapped by callee+     %o0-o5     alloc       caller saves+     %o6                    C stack ptr+     %o7                    C ret addr++   Local: maintained by register windowing mechanism+     %l0        alloc+     %l1        R1+     %l2        R2+     %l3        R3+     %l4        R4+     %l5        R5+     %l6        alloc+     %l7        alloc++   Input+     %i0        Sp+     %i1        Base+     %i2        SpLim+     %i3        Hp+     %i4        alloc+     %i5        R6+     %i6                    C frame ptr+     %i7                    C ret addr++   The paired nature of the floating point registers causes complications for+   the native code generator.  For convenience, we pretend that the first 22+   fp regs %f0 .. %f21 are actually 11 double regs, and the remaining 10 are+   float (single) regs.  The NCG acts accordingly.  That means that the+   following FP assignment is rather fragile, and should only be changed+   with extreme care.  The current scheme is:++      %f0 /%f1    FP return from C+      %f2 /%f3    D1+      %f4 /%f5    D2+      %f6 /%f7    ncg double spill tmp #1+      %f8 /%f9    ncg double spill tmp #2+      %f10/%f11   allocatable+      %f12/%f13   allocatable+      %f14/%f15   allocatable+      %f16/%f17   allocatable+      %f18/%f19   allocatable+      %f20/%f21   allocatable++      %f22        F1+      %f23        F2+      %f24        F3+      %f25        F4+      %f26        ncg single spill tmp #1+      %f27        ncg single spill tmp #2+      %f28        allocatable+      %f29        allocatable+      %f30        allocatable+      %f31        allocatable++   -------------------------------------------------------------------------- */++#elif defined(MACHREGS_sparc)++#define REG(x) __asm__("%" #x)++#define CALLER_SAVES_USER++#define CALLER_SAVES_F1+#define CALLER_SAVES_F2+#define CALLER_SAVES_F3+#define CALLER_SAVES_F4+#define CALLER_SAVES_D1+#define CALLER_SAVES_D2++#define REG_R1          l1+#define REG_R2          l2+#define REG_R3          l3+#define REG_R4          l4+#define REG_R5          l5+#define REG_R6          i5++#define REG_F1          f22+#define REG_F2          f23+#define REG_F3          f24+#define REG_F4          f25++/* for each of the double arg regs,+   Dn_2 is the high half. */++#define REG_D1          f2+#define REG_D1_2        f3++#define REG_D2          f4+#define REG_D2_2        f5++#define REG_Sp          i0+#define REG_SpLim       i2++#define REG_Hp          i3++#define REG_Base        i1++#define NCG_FirstFloatReg f22++/* -----------------------------------------------------------------------------+   The ARM EABI register mapping++   Here we consider ARM mode (i.e. 32bit isns)+   and also CPU with full VFPv3 implementation++   ARM registers (see Chapter 5.1 in ARM IHI 0042D and+   Section 9.2.2 in ARM Software Development Toolkit Reference Guide)++   r15  PC         The Program Counter.+   r14  LR         The Link Register.+   r13  SP         The Stack Pointer.+   r12  IP         The Intra-Procedure-call scratch register.+   r11  v8/fp      Variable-register 8.+   r10  v7/sl      Variable-register 7.+   r9   v6/SB/TR   Platform register. The meaning of this register is+                   defined by the platform standard.+   r8   v5         Variable-register 5.+   r7   v4         Variable register 4.+   r6   v3         Variable register 3.+   r5   v2         Variable register 2.+   r4   v1         Variable register 1.+   r3   a4         Argument / scratch register 4.+   r2   a3         Argument / scratch register 3.+   r1   a2         Argument / result / scratch register 2.+   r0   a1         Argument / result / scratch register 1.++   VFPv2/VFPv3/NEON registers+   s0-s15/d0-d7/q0-q3    Argument / result/ scratch registers+   s16-s31/d8-d15/q4-q7  callee-saved registers (must be preserved across+                         subroutine calls)++   VFPv3/NEON registers (added to the VFPv2 registers set)+   d16-d31/q8-q15        Argument / result/ scratch registers+   ----------------------------------------------------------------------------- */++#elif defined(MACHREGS_arm)++#define REG(x) __asm__(#x)++#define REG_Base        r4+#define REG_Sp          r5+#define REG_Hp          r6+#define REG_R1          r7+#define REG_R2          r8+#define REG_R3          r9+#define REG_R4          r10+#define REG_SpLim       r11++#if !defined(arm_HOST_ARCH_PRE_ARMv6)+/* d8 */+#define REG_F1    s16+#define REG_F2    s17+/* d9 */+#define REG_F3    s18+#define REG_F4    s19++#define REG_D1    d10+#define REG_D2    d11+#endif++/* -----------------------------------------------------------------------------+   The ARMv8/AArch64 ABI register mapping++   The AArch64 provides 31 64-bit general purpose registers+   and 32 128-bit SIMD/floating point registers.++   General purpose registers (see Chapter 5.1.1 in ARM IHI 0055B)++   Register | Special | Role in the procedure call standard+   ---------+---------+------------------------------------+     SP     |         | The Stack Pointer+     r30    |  LR     | The Link Register+     r29    |  FP     | The Frame Pointer+   r19-r28  |         | Callee-saved registers+     r18    |         | The Platform Register, if needed; +            |         | or temporary register+     r17    |  IP1    | The second intra-procedure-call temporary register+     r16    |  IP0    | The first intra-procedure-call scratch register+    r9-r15  |         | Temporary registers+     r8     |         | Indirect result location register+    r0-r7   |         | Parameter/result registers+++   FPU/SIMD registers++   s/d/q/v0-v7    Argument / result/ scratch registers+   s/d/q/v8-v15   callee-saved registers (must be preserved across subroutine calls,+                  but only bottom 64-bit value needs to be preserved)+   s/d/q/v16-v31  temporary registers++   ----------------------------------------------------------------------------- */++#elif defined(MACHREGS_aarch64)++#define REG(x) __asm__(#x)++#define REG_Base        r19+#define REG_Sp          r20+#define REG_Hp          r21+#define REG_R1          r22+#define REG_R2          r23+#define REG_R3          r24+#define REG_R4          r25+#define REG_R5          r26+#define REG_R6          r27+#define REG_SpLim       r28++#define REG_F1          s8+#define REG_F2          s9+#define REG_F3          s10+#define REG_F4          s11++#define REG_D1          d12+#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++#error Cannot find platform to give register info for++#endif++#else++#error Bad MACHREGS_NO_REGS value++#endif++/* -----------------------------------------------------------------------------+ * These constants define how many stg registers will be used for+ * passing arguments (and results, in the case of an unboxed-tuple+ * return).+ *+ * We usually set MAX_REAL_VANILLA_REG and co. to be the number of the+ * highest STG register to occupy a real machine register, otherwise+ * the calling conventions will needlessly shuffle data between the+ * stack and memory-resident STG registers.  We might occasionally+ * set these macros to other values for testing, though.+ *+ * Registers above these values might still be used, for instance to+ * communicate with PrimOps and RTS functions.+ */++#if !defined(MAX_REAL_VANILLA_REG)+#  if   defined(REG_R10)+#  define MAX_REAL_VANILLA_REG 10+#  elif   defined(REG_R9)+#  define MAX_REAL_VANILLA_REG 9+#  elif   defined(REG_R8)+#  define MAX_REAL_VANILLA_REG 8+#  elif defined(REG_R7)+#  define MAX_REAL_VANILLA_REG 7+#  elif defined(REG_R6)+#  define MAX_REAL_VANILLA_REG 6+#  elif defined(REG_R5)+#  define MAX_REAL_VANILLA_REG 5+#  elif defined(REG_R4)+#  define MAX_REAL_VANILLA_REG 4+#  elif defined(REG_R3)+#  define MAX_REAL_VANILLA_REG 3+#  elif defined(REG_R2)+#  define MAX_REAL_VANILLA_REG 2+#  elif defined(REG_R1)+#  define MAX_REAL_VANILLA_REG 1+#  else+#  define MAX_REAL_VANILLA_REG 0+#  endif+#endif++#if !defined(MAX_REAL_FLOAT_REG)+#  if   defined(REG_F4)+#  define MAX_REAL_FLOAT_REG 4+#  elif defined(REG_F3)+#  define MAX_REAL_FLOAT_REG 3+#  elif defined(REG_F2)+#  define MAX_REAL_FLOAT_REG 2+#  elif defined(REG_F1)+#  define MAX_REAL_FLOAT_REG 1+#  else+#  define MAX_REAL_FLOAT_REG 0+#  endif+#endif++#if !defined(MAX_REAL_DOUBLE_REG)+#  if   defined(REG_D2)+#  define MAX_REAL_DOUBLE_REG 2+#  elif defined(REG_D1)+#  define MAX_REAL_DOUBLE_REG 1+#  else+#  define MAX_REAL_DOUBLE_REG 0+#  endif+#endif++#if !defined(MAX_REAL_LONG_REG)+#  if   defined(REG_L1)+#  define MAX_REAL_LONG_REG 1+#  else+#  define MAX_REAL_LONG_REG 0+#  endif+#endif++#if !defined(MAX_REAL_XMM_REG)+#  if   defined(REG_XMM6)+#  define MAX_REAL_XMM_REG 6+#  elif defined(REG_XMM5)+#  define MAX_REAL_XMM_REG 5+#  elif defined(REG_XMM4)+#  define MAX_REAL_XMM_REG 4+#  elif defined(REG_XMM3)+#  define MAX_REAL_XMM_REG 3+#  elif defined(REG_XMM2)+#  define MAX_REAL_XMM_REG 2+#  elif defined(REG_XMM1)+#  define MAX_REAL_XMM_REG 1+#  else+#  define MAX_REAL_XMM_REG 0+#  endif+#endif++/* define NO_ARG_REGS if we have no argument registers at all (we can+ * optimise certain code paths using this predicate).+ */+#if MAX_REAL_VANILLA_REG < 2+#define NO_ARG_REGS+#else+#undef NO_ARG_REGS+#endif
libraries/ghc-boot/GHC/Settings.hs view
@@ -43,8 +43,10 @@   crossCompiling <- getBooleanSetting "cross compiling"    pure $ Platform-    { platformArch = targetArch-    , platformOS   = targetOS+    { platformMini = PlatformMini+      { platformMini_arch = targetArch+      , platformMini_os = targetOS+      }     , platformWordSize = targetWordSize     , platformUnregisterised = targetUnregisterised     , platformHasGnuNonexecStack = targetHasGnuNonexecStack
libraries/ghci/GHCi/InfoTable.hsc view
@@ -10,13 +10,10 @@ -- module GHCi.InfoTable   (-#if defined(HAVE_INTERPRETER)     mkConInfoTable-#endif   ) where  import Prelude -- See note [Why do we import Prelude here?]-#if defined(HAVE_INTERPRETER) import Foreign import Foreign.C import GHC.Ptr@@ -24,7 +21,6 @@ import GHC.Exts.Heap import Data.ByteString (ByteString) import qualified Data.ByteString as BS-#endif  ghciTablesNextToCode :: Bool #if defined(TABLES_NEXT_TO_CODE)@@ -33,7 +29,6 @@ ghciTablesNextToCode = False #endif -#if defined(HAVE_INTERPRETER) /* 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.@@ -81,6 +76,7 @@           | ArchARM64           | ArchPPC64           | ArchPPC64LE+          | ArchS390X           | ArchUnknown  deriving Show @@ -104,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@@ -273,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@@ -387,4 +399,3 @@  conInfoTableSizeB :: Int conInfoTableSizeB = wORD_SIZE + itblSize-#endif /* HAVE_INTERPRETER */