ghc-lib 9.0.1.20210324 → 9.0.2.20211226

raw patch · 61 files changed

+2952/−1949 lines, 61 filesdep +parsecdep +rtsdep ~ghc-lib-parserPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: parsec, rts

Dependency ranges changed: ghc-lib-parser

API changes (from Hackage documentation)

Files

• compiler/GHC/Cmm/Utils.hs +12/−10
• compiler/GHC/CmmToAsm/BlockLayout.hs +16/−26
• compiler/GHC/CmmToAsm/CFG.hs +56/−36
• compiler/GHC/CmmToAsm/PPC/CodeGen.hs +2/−1
• compiler/GHC/CmmToAsm/Reg/Linear.hs +7/−16
• compiler/GHC/CmmToAsm/Reg/Linear/Base.hs +42/−2
• compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs +2/−2
• compiler/GHC/CmmToLlvm.hs +9/−2
• compiler/GHC/CmmToLlvm/Base.hs +20/−8
• compiler/GHC/Core/Opt/CprAnal.hs +153/−101
• compiler/GHC/Core/Opt/DmdAnal.hs +74/−43
• compiler/GHC/Core/Opt/Simplify.hs +112/−35
• compiler/GHC/Core/Opt/Simplify/Utils.hs +4/−1
• compiler/GHC/CoreToByteCode.hs +1/−1
• compiler/GHC/CoreToStg.hs +31/−36
• compiler/GHC/CoreToStg/Prep.hs +491/−154
• compiler/GHC/Data/UnionFind.hs +91/−0
• compiler/GHC/Driver/Finder.hs +1/−1
• compiler/GHC/Driver/Main.hs +107/−14
• compiler/GHC/Driver/Make.hs +20/−20
• compiler/GHC/Driver/MakeFile.hs +11/−1
• compiler/GHC/Driver/Pipeline.hs +21/−17
• compiler/GHC/HsToCore/Expr.hs +94/−83
• compiler/GHC/HsToCore/Match/Literal.hs +2/−2
• compiler/GHC/HsToCore/Usage.hs +1/−1
• compiler/GHC/Iface/Load.hs +11/−8
• compiler/GHC/Iface/Recomp/Flags.hs +5/−1
• compiler/GHC/Iface/UpdateIdInfos.hs +0/−157
• compiler/GHC/Rename/Env.hs +2/−1
• compiler/GHC/Rename/Expr.hs +4/−1
• compiler/GHC/Rename/HsType.hs +12/−10
• compiler/GHC/Rename/Names.hs +4/−1
• compiler/GHC/Runtime/Linker.hs +2/−2
• compiler/GHC/Stg/Unarise.hs +43/−4
• compiler/GHC/StgToCmm/Prim.hs +4/−3
• compiler/GHC/StgToCmm/Prof.hs +1/−1
• compiler/GHC/SysTools.hs +5/−5
• compiler/GHC/SysTools/Tasks.hs +34/−10
• compiler/GHC/Tc/Errors.hs +53/−4
• compiler/GHC/Tc/Errors/Hole.hs +120/−104
• compiler/GHC/Tc/Errors/Hole.hs-boot +31/−1
• compiler/GHC/Tc/Gen/Export.hs +36/−35
• compiler/GHC/Tc/Gen/Splice.hs +15/−5
• compiler/GHC/Tc/Module.hs +314/−296
• compiler/GHC/Tc/Solver/Interact.hs +47/−9
• compiler/GHC/Tc/Solver/Monad.hs +33/−7
• compiler/GHC/Tc/TyCl/Instance.hs +2/−1
• compiler/GHC/Tc/TyCl/Utils.hs +1/−0
• compiler/GHC/Tc/Utils/Env.hs +10/−11
• compiler/GHC/Tc/Utils/Instantiate.hs +12/−2
• compiler/GHC/Tc/Utils/TcMType.hs +1/−0
• compiler/GHC/Tc/Utils/Zonk.hs +36/−25
• ghc-lib.cabal +11/−10
• ghc-lib/stage0/compiler/build/primop-docs.hs-incl +1/−1
• ghc-lib/stage0/lib/DerivedConstants.h +0/−555
• ghc-lib/stage0/lib/GhclibDerivedConstants.h +555/−0
• ghc-lib/stage0/lib/ghcautoconf.h +109/−39
• ghc-lib/stage0/lib/llvm-targets +1/−1
• ghc-lib/stage0/lib/settings +3/−3
• includes/ghcconfig.h +0/−4
• libraries/ghci/GHCi/InfoTable.hsc +54/−19

@@ -119,11 +119,12 @@  slotCmmType :: Platform -> SlotTy -> CmmType slotCmmType platform = \case-   PtrSlot    -> gcWord platform-   WordSlot   -> bWord platform-   Word64Slot -> b64-   FloatSlot  -> f32-   DoubleSlot -> f64+   PtrUnliftedSlot -> gcWord platform+   PtrLiftedSlot   -> gcWord platform+   WordSlot        -> bWord platform+   Word64Slot      -> b64+   FloatSlot       -> f32+   DoubleSlot      -> f64  primElemRepCmmType :: PrimElemRep -> CmmType primElemRepCmmType Int8ElemRep   = b8@@ -160,11 +161,12 @@ primRepForeignHint (VecRep {})  = NoHint  slotForeignHint :: SlotTy -> ForeignHint-slotForeignHint PtrSlot       = AddrHint-slotForeignHint WordSlot      = NoHint-slotForeignHint Word64Slot    = NoHint-slotForeignHint FloatSlot     = NoHint-slotForeignHint DoubleSlot    = NoHint+slotForeignHint PtrLiftedSlot   = AddrHint+slotForeignHint PtrUnliftedSlot = AddrHint+slotForeignHint WordSlot        = NoHint+slotForeignHint Word64Slot      = NoHint+slotForeignHint FloatSlot       = NoHint+slotForeignHint DoubleSlot      = NoHint  typeForeignHint :: UnaryType -> ForeignHint typeForeignHint = primRepForeignHint . typePrimRep1

@@ -40,13 +40,14 @@ import GHC.Data.List.SetOps (removeDups)  import GHC.Data.OrdList-import Data.List+import Data.List (sortOn, sortBy, nub) import Data.Foldable (toList)  import qualified Data.Set as Set import Data.STRef import Control.Monad.ST.Strict-import Control.Monad (foldM)+import Control.Monad (foldM, unless)+import GHC.Data.UnionFind  {-   Note [CFG based code layout]@@ -481,10 +482,9 @@ mergeChains :: [CfgEdge] -> [BlockChain]             -> (BlockChain) mergeChains edges chains-    = -- pprTrace "combine" (ppr edges) $-      runST $ do+    = runST $ do         let addChain m0 chain = do-                ref <- newSTRef chain+                ref <- fresh chain                 return $ chainFoldl (\m' b -> mapInsert b ref m') m0 chain         chainMap' <- foldM (\m0 c -> addChain m0 c) mapEmpty chains         merge edges chainMap'@@ -492,35 +492,25 @@         -- 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.+        -- We use a union-find data structure to do this efficiently. -        merge :: forall s. [CfgEdge] -> LabelMap (STRef s BlockChain) -> ST s BlockChain+        merge :: forall s. [CfgEdge] -> LabelMap (Point s BlockChain) -> ST s BlockChain         merge [] chains = do-            chains' <- ordNub <$> (mapM readSTRef $ mapElems chains) :: ST s [BlockChain]+            chains' <- mapM find =<< (nub <$> (mapM repr $ 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'+            same <- equivalent cFrom cTo+            unless same $ do+              cRight <- find cTo+              cLeft <- find cFrom+              new_point <- fresh (chainConcat cLeft cRight)+              union cTo new_point+              union cFrom new_point+            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-             cFrom = expectJust "mergeChains:chainMap:from" $ mapLookup from chains             cTo = expectJust "mergeChains:chainMap:to"   $ mapLookup to   chains 

@@ -9,6 +9,7 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts           #-}  module GHC.CmmToAsm.CFG     ( CFG, CfgEdge(..), EdgeInfo(..), EdgeWeight(..)@@ -16,7 +17,7 @@      --Modify the CFG     , addWeightEdge, addEdge-    , delEdge, delNode+    , delEdge     , addNodesBetween, shortcutWeightMap     , reverseEdges, filterEdges     , addImmediateSuccessor@@ -91,6 +92,7 @@ import Data.Array.Base (unsafeRead, unsafeWrite)  import Control.Monad+import GHC.Data.UnionFind  type Prob = Double @@ -294,34 +296,57 @@  -} shortcutWeightMap :: LabelMap (Maybe BlockId) -> CFG -> CFG-shortcutWeightMap cuts cfg =-  foldl' applyMapping cfg $ mapToList cuts+shortcutWeightMap cuts cfg+  | mapNull cuts = cfg+  | otherwise = normalised_cfg     where--- takes the tuple (B,C) from the notation in [Updating the CFG during shortcutting]-      applyMapping :: CFG -> (BlockId,Maybe BlockId) -> CFG-      --Shortcut immediate-      applyMapping m (from, Nothing) =-        mapDelete from .-        fmap (mapDelete from) $ m-      --Regular shortcut-      applyMapping m (from, Just to) =-        let updatedMap :: CFG-            updatedMap-              = fmap (shortcutEdge (from,to)) $-                (mapDelete from m :: CFG )-        --Sometimes we can shortcut multiple blocks like so:-        -- A -> B -> C -> D -> E => A -> E-        -- so we check for such chains.-        in case mapLookup to cuts of-            Nothing -> updatedMap-            Just dest -> applyMapping updatedMap (to, dest)-      --Redirect edge from B to C-      shortcutEdge :: (BlockId, BlockId) -> LabelMap EdgeInfo -> LabelMap EdgeInfo-      shortcutEdge (from, to) m =-        case mapLookup from m of-          Just info -> mapInsert to info $ mapDelete from m-          Nothing   -> m+      -- First take the cuts map and collapse any shortcuts, for example+      -- if the cuts map has A -> B and B -> C then we want to rewrite+      -- A -> C and B -> C directly.+      normalised_cuts_st :: forall s . ST s (LabelMap (Maybe BlockId))+      normalised_cuts_st = do+        (null :: Point s (Maybe BlockId)) <- fresh Nothing+        let cuts_list = mapToList cuts+        -- Create a unification variable for each of the nodes in a rewrite+        cuts_vars <- traverse (\p -> (p,) <$> fresh (Just p)) (concatMap (\(a, b) -> [a] ++ maybe [] (:[]) b) cuts_list)+        let cuts_map = mapFromList cuts_vars :: LabelMap (Point s (Maybe BlockId))+        -- Then unify according the the rewrites in the cuts map+        mapM_ (\(from, to) -> expectJust "shortcutWeightMap" (mapLookup from cuts_map)+                              `union` expectJust "shortcutWeightMap" (maybe (Just null) (flip mapLookup cuts_map) to) ) cuts_list+        -- Then recover the unique representative, which is the result of following+        -- the chain to the end.+        mapM find cuts_map +      normalised_cuts = runST normalised_cuts_st++      cuts_domain :: LabelSet+      cuts_domain = setFromList $ mapKeys cuts++      -- The CFG is shortcutted using the normalised cuts map+      normalised_cfg :: CFG+      normalised_cfg = mapFoldlWithKey update_edge mapEmpty cfg++      update_edge :: CFG -> Label -> LabelMap EdgeInfo -> CFG+      update_edge new_map from edge_map+        -- If the from edge is in the cuts map then delete the edge+        | setMember from cuts_domain = new_map+        -- Otherwise we are keeping the edge, but might have shortcutted some of+        -- the target nodes.+        | otherwise = mapInsert from (mapFoldlWithKey update_from_edge mapEmpty edge_map) new_map++      update_from_edge :: LabelMap a -> Label -> a -> LabelMap a+      update_from_edge new_map to_edge edge_info+        -- Edge is in the normalised cuts+        | Just new_edge <- mapLookup to_edge normalised_cuts =+            case new_edge of+              -- The result was Nothing, so edge is deleted+              Nothing -> new_map+              -- The new target for the edge, write it with the old edge_info.+              Just new_to -> mapInsert new_to edge_info new_map+        -- Node wasn't in the cuts map, so just add it back+        | otherwise = mapInsert to_edge edge_info new_map++ -- | Sometimes we insert a block which should unconditionally be executed --   after a given block. This function updates the CFG for these cases. --  So we get A -> B    => A -> A' -> B@@ -369,10 +394,6 @@         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)]@@ -862,8 +883,8 @@       = ( 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@@ -872,10 +893,9 @@           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+            successors = setDelete head $ setUnions $ map+                                      (\x -> if x == head then setEmpty else setFromList (getSuccessors revCfg x))+                                      (setElems current) :: LabelSet      backEdges = filter isBackEdge edges     loopBodies = map findBody backEdges :: [(Edge, LabelSet)]

@@ -981,7 +981,8 @@   | Just src2 <- makeImmediate rep (not $ condUnsigned cond) y   = do       let op_len = max W32 width-      let extend = extendSExpr width op_len+      let extend = if condUnsigned cond then extendUExpr width op_len+                   else extendSExpr width op_len       (src1, code) <- getSomeReg (extend x)       let format = intFormat op_len           code' = code `snocOL`

@@ -139,7 +139,6 @@ import Data.Maybe import Data.List import Control.Monad-import Control.Applicative  -- ----------------------------------------------------------------------------- -- Top level of the register allocator@@ -248,8 +247,8 @@  linearRegAlloc' config initFreeRegs entry_ids block_live sccs  = do   us      <- getUniqueSupplyM-        let (_, stack, stats, blocks) =-                runR config mapEmpty initFreeRegs emptyRegMap emptyStackMap us+        let !(_, !stack, !stats, !blocks) =+                runR config emptyBlockAssignment initFreeRegs emptyRegMap emptyStackMap us                     $ linearRA_SCCs entry_ids block_live [] sccs         return  (blocks, stats, getStackUse stack) @@ -319,7 +318,7 @@  = do         block_assig <- getBlockAssigR -        if isJust (mapLookup id block_assig)+        if isJust (lookupBlockAssignment id block_assig)              || id `elem` entry_ids          then do                 b'  <- processBlock block_live b@@ -355,7 +354,7 @@ initBlock id block_live  = do   platform    <- getPlatform         block_assig <- getBlockAssigR-        case mapLookup id block_assig of+        case lookupBlockAssignment id block_assig of                 -- no prior info about this block: we must consider                 -- any fixed regs to be allocated, but we can ignore                 -- virtual regs (presumably this is part of a loop,@@ -813,19 +812,11 @@ -- variables are likely to end up in the same registers at the -- end and start of the loop, avoiding redundant reg-reg moves. -- Note: I tried returning a list of past assignments, but that--- turned out to barely matter but added a few tenths of--- a percent to compile time.+-- turned out to barely matter. findPrefRealReg :: VirtualReg -> RegM freeRegs (Maybe RealReg) findPrefRealReg vreg = do-  bassig <- getBlockAssigR :: RegM freeRegs (BlockMap (freeRegs,RegMap Loc))-  return $ foldr (findVirtRegAssig) Nothing bassig-  where-    findVirtRegAssig :: (freeRegs,RegMap Loc) -> Maybe RealReg -> Maybe RealReg-    findVirtRegAssig assig z =-        z <|>   case lookupUFM (toVRegMap $ snd assig) vreg of-                        Just (InReg real_reg) -> Just real_reg-                        Just (InBoth real_reg _) -> Just real_reg-                        _ -> z+  bassig <- getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)+  return $ lookupFirstUsed vreg bassig  -- reading is redundant with reason, but we keep it around because it's -- convenient and it maintains the recursive structure of the allocator. -- EZY

@@ -1,8 +1,13 @@+{-# LANGUAGE RecordWildCards #-}  -- | Put common type definitions here to break recursive module dependencies.  module GHC.CmmToAsm.Reg.Linear.Base (         BlockAssignment,+        lookupBlockAssignment,+        lookupFirstUsed,+        emptyBlockAssignment,+        updateBlockAssignment,          Loc(..),         regsOfLoc,@@ -29,6 +34,8 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Collections+import GHC.CmmToAsm.Reg.Utils  data ReadingOrWriting = Reading | Writing deriving (Eq,Ord) @@ -37,8 +44,41 @@ --      target a particular label. We have to insert fixup code to make --      the register assignments from the different sources match up. ---type BlockAssignment freeRegs-        = BlockMap (freeRegs, RegMap Loc)+data BlockAssignment freeRegs+        = BlockAssignment { blockMap :: !(BlockMap (freeRegs, RegMap Loc))+                          , firstUsed :: !(UniqFM VirtualReg RealReg) }++-- | Find the register mapping for a specific BlockId.+lookupBlockAssignment :: BlockId -> BlockAssignment freeRegs -> Maybe (freeRegs, RegMap Loc)+lookupBlockAssignment bid ba = mapLookup bid (blockMap ba)++-- | Lookup which register a virtual register was first assigned to.+lookupFirstUsed :: VirtualReg -> BlockAssignment freeRegs -> Maybe RealReg+lookupFirstUsed vr ba = lookupUFM (firstUsed ba) vr++-- | An initial empty 'BlockAssignment'+emptyBlockAssignment :: BlockAssignment freeRegs+emptyBlockAssignment = BlockAssignment mapEmpty mempty++-- | Add new register mappings for a specific block.+updateBlockAssignment :: BlockId+  -> (freeRegs, RegMap Loc)+  -> BlockAssignment freeRegs+  -> BlockAssignment freeRegs+updateBlockAssignment dest (freeRegs, regMap) (BlockAssignment {..}) =+  BlockAssignment (mapInsert dest (freeRegs, regMap) blockMap)+                  (mergeUFM combWithExisting id (mapMaybeUFM fromLoc) (firstUsed) (toVRegMap regMap))+  where+    -- The blocks are processed in dependency order, so if there's already an+    -- entry in the map then keep that assignment rather than writing the new+    -- assignment.+    combWithExisting :: RealReg -> Loc -> Maybe RealReg+    combWithExisting old_reg _ = Just $ old_reg++    fromLoc :: Loc -> Maybe RealReg+    fromLoc (InReg rr) = Just rr+    fromLoc (InBoth rr _) = Just rr+    fromLoc _ = Nothing   -- | Where a vreg is currently stored

@@ -97,7 +97,7 @@                         , not (elemUniqSet_Directly reg live_set)                         , r          <- regsOfLoc loc ] -        case mapLookup dest block_assig of+        case lookupBlockAssignment  dest block_assig of          Nothing           -> joinToTargets_first                         block_live new_blocks block_id instr dest dests@@ -133,7 +133,7 @@         let freeregs' = foldl' (flip $ frReleaseReg platform) freeregs to_free          -- remember the current assignment on entry to this block.-        setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig)+        setBlockAssigR (updateBlockAssignment dest (freeregs', src_assig) block_assig)          joinToTargets' block_live new_blocks block_id instr dests 

@@ -64,7 +64,8 @@          let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags          when (not (llvmVersionSupported ver) && doWarn) $ putMsg dflags $            "You are using an unsupported version of LLVM!" $$-           "Currently only " <> text (llvmVersionStr supportedLlvmVersion) <> " is supported." <+>+           "Currently only" <+> text (llvmVersionStr supportedLlvmVersionLowerBound) <+>+           "to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "is supported." <+>            "System LLVM version: " <> text (llvmVersionStr ver) $$            "We will try though..."          let isS390X = platformArch (targetPlatform dflags) == ArchS390X@@ -73,8 +74,14 @@            "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+>            "You are using LLVM version: " <> text (llvmVersionStr ver) +       -- HACK: the Nothing case here is potentially wrong here but we+       -- currently don't use the LLVM version to guide code generation+       -- so this is okay.+       let llvm_ver :: LlvmVersion+           llvm_ver = fromMaybe supportedLlvmVersionLowerBound mb_ver+        -- run code generation-       a <- runLlvm dflags (fromMaybe supportedLlvmVersion mb_ver) bufh $+       a <- runLlvm dflags llvm_ver bufh $          llvmCodeGen' dflags (liftStream cmm_stream)         bFlush bufh

@@ -15,7 +15,8 @@         LiveGlobalRegs,         LlvmUnresData, LlvmData, UnresLabel, UnresStatic, -        LlvmVersion, supportedLlvmVersion, llvmVersionSupported, parseLlvmVersion,+        LlvmVersion, llvmVersionSupported, parseLlvmVersion,+        supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound,         llvmVersionStr, llvmVersionList,          LlvmM,@@ -264,8 +265,8 @@ -- * Llvm Version -- --- Newtype to avoid using the Eq instance! newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }+  deriving (Eq, Ord)  parseLlvmVersion :: String -> Maybe LlvmVersion parseLlvmVersion =@@ -281,12 +282,17 @@       where         (ver_str, rest) = span isDigit s --- | The LLVM Version that is currently supported.-supportedLlvmVersion :: LlvmVersion-supportedLlvmVersion = LlvmVersion (sUPPORTED_LLVM_VERSION NE.:| [])+-- | The (inclusive) lower bound on the LLVM Version that is currently supported.+supportedLlvmVersionLowerBound :: LlvmVersion+supportedLlvmVersionLowerBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MIN NE.:| []) +-- | The (not-inclusive) upper bound  bound on the LLVM Version that is currently supported.+supportedLlvmVersionUpperBound :: LlvmVersion+supportedLlvmVersionUpperBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MAX NE.:| [])+ llvmVersionSupported :: LlvmVersion -> Bool-llvmVersionSupported (LlvmVersion v) = NE.head v == sUPPORTED_LLVM_VERSION+llvmVersionSupported v =+  v >= supportedLlvmVersionLowerBound && v < supportedLlvmVersionUpperBound  llvmVersionStr :: LlvmVersion -> String llvmVersionStr = intercalate "." . map show . llvmVersionList@@ -475,14 +481,17 @@ ghcInternalFunctions :: LlvmM () ghcInternalFunctions = do     platform <- getPlatform+    dflags <- getDynFlags     let w = llvmWord platform+        cint = LMInt $ widthInBits $ cIntWidth dflags+    mk "memcmp" cint [i8Ptr, i8Ptr, w]     mk "memcpy" i8Ptr [i8Ptr, i8Ptr, w]     mk "memmove" i8Ptr [i8Ptr, i8Ptr, w]     mk "memset" i8Ptr [i8Ptr, w, w]     mk "newSpark" w [i8Ptr, i8Ptr]   where     mk n ret args = do-      let n' = llvmDefLabel $ fsLit n+      let n' = fsLit n           decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret                                  FixedArgs (tysToParams args) Nothing       renderLlvm $ ppLlvmFunctionDecl decl@@ -515,7 +524,10 @@   let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing   case m_ty of     -- Directly reference if we have seen it already-    Just ty -> return $ mkGlbVar (llvmDefLabel llvmLbl) ty Global+    Just ty -> do+      if llvmLbl `elem` (map fsLit ["newSpark", "memmove", "memcpy", "memcmp", "memset"])+        then return $ mkGlbVar (llvmLbl) ty Global+        else return $ mkGlbVar (llvmDefLabel llvmLbl) ty Global     -- Otherwise use a forward alias of it     Nothing -> do       saveAlias llvmLbl

@@ -19,6 +19,7 @@ import GHC.Core import GHC.Core.Seq import GHC.Utils.Outputable+import GHC.Builtin.Names ( runRWKey ) import GHC.Types.Var.Env import GHC.Types.Basic import GHC.Core.DataCon@@ -118,9 +119,9 @@                -> CoreBind                -> (AnalEnv, CoreBind) cprAnalTopBind env (NonRec id rhs)-  = (extendAnalEnv env id' (idCprInfo id'), NonRec id' rhs')+  = (env', NonRec id' rhs')   where-    (id', rhs') = cprAnalBind TopLevel env id rhs+    (id', rhs', env') = cprAnalBind TopLevel env id rhs  cprAnalTopBind env (Rec pairs)   = (env', Rec pairs')@@ -145,8 +146,6 @@ cprAnal' _ (Type ty)     = (topCprType, Type ty)      -- Doesn't happen, in fact cprAnal' _ (Coercion co) = (topCprType, Coercion co) -cprAnal' env (Var var)   = (cprTransform env var, Var var)- cprAnal' env (Cast e co)   = (cpr_ty, Cast e' co)   where@@ -157,19 +156,10 @@   where     (cpr_ty, e') = cprAnal env e -cprAnal' env (App fun (Type ty))-  = (fun_ty, App fun' (Type ty))-  where-    (fun_ty, fun') = cprAnal env fun--cprAnal' env (App fun arg)-  = (res_ty, App fun' arg')-  where-    (fun_ty, fun') = cprAnal env fun-    -- In contrast to DmdAnal, there is no useful (non-nested) CPR info to be-    -- had by looking into the CprType of arg.-    (_, arg')      = cprAnal env arg-    res_ty         = applyCprTy fun_ty+cprAnal' env e@(Var{})+  = cprAnalApp env e [] []+cprAnal' env e@(App{})+  = cprAnalApp env e [] []  cprAnal' env (Lam var body)   | isTyVar var@@ -178,7 +168,7 @@   | otherwise   = (lam_ty, Lam var body')   where-    env'             = extendAnalEnvForDemand env var (idDemandInfo var)+    env'             = extendSigEnvForDemand env var (idDemandInfo var)     (body_ty, body') = cprAnal env' body     lam_ty           = abstractCprTy body_ty @@ -194,9 +184,8 @@ cprAnal' env (Let (NonRec id rhs) body)   = (body_ty, Let (NonRec id' rhs') body')   where-    (id', rhs')      = cprAnalBind NotTopLevel env id rhs-    env'             = extendAnalEnv env id' (idCprInfo id')-    (body_ty, body') = cprAnal env' body+    (id', rhs', env') = cprAnalBind NotTopLevel env id rhs+    (body_ty, body')  = cprAnal env' body  cprAnal' env (Let (Rec pairs) body)   = body_ty `seq` (body_ty, Let (Rec pairs') body')@@ -225,72 +214,99 @@ -- * CPR transformer -- -cprTransform :: AnalEnv         -- ^ The analysis environment-             -> Id              -- ^ The function-             -> CprType         -- ^ The demand type of the function-cprTransform env id-  = -- pprTrace "cprTransform" (vcat [ppr id, ppr sig])+cprAnalApp :: AnalEnv -> CoreExpr -> [CoreArg] -> [CprType] -> (CprType, CoreExpr)+cprAnalApp env e args' arg_tys+  -- Collect CprTypes for (value) args (inlined collectArgs):+  | App fn arg <- e, isTypeArg arg -- Don't analyse Type args+  = cprAnalApp env fn (arg:args') arg_tys+  | App fn arg <- e+  , (arg_ty, arg') <- cprAnal env arg+  = cprAnalApp env fn (arg':args') (arg_ty:arg_tys)++  | Var fn <- e+  = (cprTransform env fn arg_tys, mkApps e args')++  | otherwise -- e is not an App and not a Var+  , (e_ty, e') <- cprAnal env e+  = (applyCprTy e_ty (length arg_tys), mkApps e' args')++cprTransform :: AnalEnv   -- ^ The analysis environment+             -> Id        -- ^ The function+             -> [CprType] -- ^ info about incoming /value/ arguments+             -> CprType   -- ^ The demand type of the application+cprTransform env id args+  = -- pprTrace "cprTransform" (vcat [ppr id, ppr args, ppr sig])     sig   where     sig-      -- See Note [CPR for expandable unfoldings]-      | Just rhs <- cprExpandUnfolding_maybe id+      -- Top-level binding, local let-binding, lambda arg or case binder+      | Just sig <- lookupSigEnv env id+      = applyCprTy (getCprSig sig) (length args)+      -- CPR transformers for special Ids+      | Just cpr_ty <- cprTransformSpecial id args+      = cpr_ty+      -- See Note [CPR for data structures]+      | Just rhs <- cprDataStructureUnfolding_maybe id       = fst $ cprAnal env rhs       -- Imported function or data con worker       | isGlobalId id-      = getCprSig (idCprInfo id)-      -- Local let-bound-      | Just sig <- lookupSigEnv env id-      = getCprSig sig+      = applyCprTy (getCprSig (idCprInfo id)) (length args)       | otherwise       = topCprType +-- | CPR transformers for special Ids+cprTransformSpecial :: Id -> [CprType] -> Maybe CprType+cprTransformSpecial id args+  -- See Note [Simplification of runRW#] in GHC.CoreToStg.Prep+  | idUnique id == runRWKey -- `runRW (\s -> e)`+  , [arg] <- args           -- `\s -> e` has CPR type `arg` (e.g. `. -> 2`)+  = Just $ applyCprTy arg 1 -- `e` has CPR type `2`+  | otherwise+  = Nothing+ -- -- * Bindings --  -- Recursive bindings cprFix :: TopLevelFlag-       -> AnalEnv                            -- Does not include bindings for this binding+       -> AnalEnv                    -- Does not include bindings for this binding        -> [(Id,CoreExpr)]-       -> (AnalEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info--cprFix top_lvl env orig_pairs-  = loop 1 initial_pairs+       -> (AnalEnv, [(Id,CoreExpr)]) -- Binders annotated with CPR info+cprFix top_lvl orig_env orig_pairs+  = loop 1 init_env init_pairs   where-    bot_sig = mkCprSig 0 botCpr+    init_sig id rhs+      -- See Note [CPR for data structures]+      | isDataStructure id rhs = topCprSig+      | otherwise              = mkCprSig 0 botCpr     -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal-    initial_pairs | ae_virgin env = [(setIdCprInfo id bot_sig, rhs) | (id, rhs) <- orig_pairs ]-                  | otherwise     = orig_pairs--    -- The fixed-point varies the idCprInfo field of the binders, and terminates if that-    -- annotation does not change any more.-    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)])-    loop n pairs-      | found_fixpoint = (final_anal_env, pairs')-      | otherwise      = loop (n+1) pairs'-      where-        found_fixpoint    = map (idCprInfo . fst) pairs' == map (idCprInfo . fst) pairs-        first_round       = n == 1-        pairs'            = step first_round pairs-        final_anal_env    = extendAnalEnvs env (map fst pairs')+    orig_virgin = ae_virgin orig_env+    init_pairs | orig_virgin  = [(setIdCprInfo id (init_sig id rhs), rhs) | (id, rhs) <- orig_pairs ]+               | otherwise    = orig_pairs+    init_env = extendSigEnvList orig_env (map fst init_pairs) -    step :: Bool -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]-    step first_round pairs = pairs'+    -- The fixed-point varies the idCprInfo field of the binders and and their+    -- entries in the AnalEnv, and terminates if that annotation does not change+    -- any more.+    loop :: Int -> AnalEnv -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)])+    loop n env pairs+      | found_fixpoint = (reset_env', pairs')+      | otherwise      = loop (n+1) env' pairs'       where         -- In all but the first iteration, delete the virgin flag-        start_env | first_round = env-                  | otherwise   = nonVirgin env--        start = extendAnalEnvs start_env (map fst pairs)--        (_, pairs') = mapAccumL my_downRhs start pairs+        -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal+        (env', pairs') = step (applyWhen (n/=1) nonVirgin env) pairs+        -- Make sure we reset the virgin flag to what it was when we are stable+        reset_env'     = env'{ ae_virgin = orig_virgin }+        found_fixpoint = map (idCprInfo . fst) pairs' == map (idCprInfo . fst) pairs -        my_downRhs env (id,rhs)-          = (env', (id', rhs'))+    step :: AnalEnv -> [(Id, CoreExpr)] -> (AnalEnv, [(Id, CoreExpr)])+    step env pairs = mapAccumL go env pairs+      where+        go env (id, rhs) = (env', (id', rhs'))           where-            (id', rhs') = cprAnalBind top_lvl env id rhs-            env'        = extendAnalEnv env id (idCprInfo id')+            (id', rhs', env') = cprAnalBind top_lvl env id rhs  -- | Process the RHS of the binding for a sensible arity, add the CPR signature -- to the Id, and augment the environment with the signature as well.@@ -299,9 +315,13 @@   -> AnalEnv   -> Id   -> CoreExpr-  -> (Id, CoreExpr)+  -> (Id, CoreExpr, AnalEnv) cprAnalBind top_lvl env id rhs-  = (id', rhs')+  -- See Note [CPR for data structures]+  | isDataStructure id rhs+  = (id,  rhs,  env) -- Data structure => no code => need to analyse rhs+  | otherwise+  = (id', rhs', env')   where     (rhs_ty, rhs')  = cprAnal env rhs     -- possibly trim thunk CPR info@@ -310,12 +330,11 @@       | stays_thunk = trimCprTy rhs_ty       -- See Note [CPR for sum types]       | returns_sum = trimCprTy rhs_ty-      -- See Note [CPR for expandable unfoldings]-      | will_expand = topCprType       | otherwise   = rhs_ty     -- See Note [Arity trimming for CPR signatures]-    sig             = mkCprSigForArity (idArity id) rhs_ty'-    id'             = setIdCprInfo id sig+    sig  = mkCprSigForArity (idArity id) rhs_ty'+    id'  = setIdCprInfo id sig+    env' = extendSigEnv env id sig      -- See Note [CPR for thunks]     stays_thunk = is_thunk && not_strict@@ -325,15 +344,22 @@     (_, ret_ty) = splitPiTys (idType id)     not_a_prod  = isNothing (deepSplitProductType_maybe (ae_fam_envs env) ret_ty)     returns_sum = not (isTopLevel top_lvl) && not_a_prod-    -- See Note [CPR for expandable unfoldings]-    will_expand = isJust (cprExpandUnfolding_maybe id) -cprExpandUnfolding_maybe :: Id -> Maybe CoreExpr-cprExpandUnfolding_maybe id = do-  guard (idArity id == 0)+isDataStructure :: Id -> CoreExpr -> Bool+-- See Note [CPR for data structures]+isDataStructure id rhs =+  idArity id == 0 && exprIsHNF rhs++-- | Returns an expandable unfolding+-- (See Note [exprIsExpandable] in "GHC.Core.Utils") that has+-- So effectively is a constructor application.+cprDataStructureUnfolding_maybe :: Id -> Maybe CoreExpr+cprDataStructureUnfolding_maybe id = do   -- There are only FinalPhase Simplifier runs after CPR analysis   guard (activeInFinalPhase (idInlineActivation id))-  expandUnfolding_maybe (idUnfolding id)+  unf <- expandUnfolding_maybe (idUnfolding id)+  guard (isDataStructure id unf)+  return unf  {- Note [Arity trimming for CPR signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -394,15 +420,15 @@   , ae_fam_envs = fam_envs   } --- | Extend an environment with the strictness IDs attached to the id-extendAnalEnvs :: AnalEnv -> [Id] -> AnalEnv-extendAnalEnvs env ids+-- | Extend an environment with the CPR sigs attached to the id+extendSigEnvList :: AnalEnv -> [Id] -> AnalEnv+extendSigEnvList env ids   = env { ae_sigs = sigs' }   where     sigs' = extendVarEnvList (ae_sigs env) [ (id, idCprInfo id) | id <- ids ] -extendAnalEnv :: AnalEnv -> Id -> CprSig -> AnalEnv-extendAnalEnv env id sig+extendSigEnv :: AnalEnv -> Id -> CprSig -> AnalEnv+extendSigEnv env id sig   = env { ae_sigs = extendVarEnv (ae_sigs env) id sig }  lookupSigEnv :: AnalEnv -> Id -> Maybe CprSig@@ -411,17 +437,17 @@ nonVirgin :: AnalEnv -> AnalEnv nonVirgin env = env { ae_virgin = False } --- | A version of 'extendAnalEnv' for a binder of which we don't see the RHS+-- | A version of 'extendSigEnv' for a binder of which we don't see the RHS -- needed to compute a 'CprSig' (e.g. lambdas and DataAlt field binders). -- In this case, we can still look at their demand to attach CPR signatures -- anticipating the unboxing done by worker/wrapper. -- See Note [CPR for binders that will be unboxed].-extendAnalEnvForDemand :: AnalEnv -> Id -> Demand -> AnalEnv-extendAnalEnvForDemand env id dmd+extendSigEnvForDemand :: AnalEnv -> Id -> Demand -> AnalEnv+extendSigEnvForDemand env id dmd   | isId id   , Just (_, DataConAppContext { dcac_dc = dc })       <- wantToUnbox (ae_fam_envs env) has_inlineable_prag (idType id) dmd-  = extendAnalEnv env id (CprSig (conCprType (dataConTag dc)))+  = extendSigEnv env id (CprSig (conCprType (dataConTag dc)))   | otherwise   = env   where@@ -436,7 +462,7 @@ extendEnvForDataAlt env scrut case_bndr dc bndrs   = foldl' do_con_arg env' ids_w_strs   where-    env' = extendAnalEnv env case_bndr (CprSig case_bndr_ty)+    env' = extendSigEnv env case_bndr (CprSig case_bndr_ty)      ids_w_strs    = filter isId bndrs `zip` dataConRepStrictness dc @@ -460,7 +486,7 @@        | is_var scrut        -- See Note [Add demands for strict constructors] in GHC.Core.Opt.WorkWrap.Utils        , let dmd = applyWhen (isMarkedStrict str) strictifyDmd (idDemandInfo id)-       = extendAnalEnvForDemand env id dmd+       = extendSigEnvForDemand env id dmd        | otherwise        = env @@ -645,46 +671,72 @@ so WW doesn't hurt.  Should we also trim CPR on DataCon application bindings?-See Note [CPR for expandable unfoldings]!+See Note [CPR for data structures]! -Note [CPR for expandable unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [CPR for data structures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Long static data structures (whether top-level or not) like    xs = x1 : xs1   xs1 = x2 : xs2   xs2 = x3 : xs3 -should not get CPR signatures, because they+should not get CPR signatures (#18154), because they    * Never get WW'd, so their CPR signature should be irrelevant after analysis     (in fact the signature might even be harmful for that reason)   * Would need to be inlined/expanded to see their constructed product   * Recording CPR on them blows up interface file sizes and is redundant with     their unfolding. In case of Nested CPR, this blow-up can be quadratic!+    Reason: the CPR info for xs1 contains the CPR info for xs; the CPR info+    for xs2 contains that for xs1. And so on. -But we can't just stop giving DataCon application bindings the CPR property,+Hence we don't analyse or annotate data structures in 'cprAnalBind'. To+implement this, the isDataStructure guard is triggered for bindings that satisfy++  (1) idArity id == 0 (otherwise it's a function)+  (2) exprIsHNF rhs   (otherwise it's a thunk, Note [CPR for thunks] applies)++But we can't just stop giving DataCon application bindings the CPR *property*, for example -  fac 0 = 1+  fac 0 = I# 1#   fac n = n * fac (n-1)  fac certainly has the CPR property and should be WW'd! But FloatOut will transform the first clause to -  lvl = 1+  lvl = I# 1#   fac 0 = lvl -If lvl doesn't have the CPR property, fac won't either. But lvl doesn't have a-CPR signature to extrapolate into a CPR transformer ('cprTransform'). So-instead we keep on cprAnal'ing through *expandable* unfoldings for these arity-0 bindings via 'cprExpandUnfolding_maybe'.+If lvl doesn't have the CPR property, fac won't either. But lvl is a data+structure, and hence (see above) will not have a CPR signature. So instead, when+'cprAnal' meets a variable lacking a CPR signature to extrapolate into a CPR+transformer, 'cprTransform' instead tries to get its unfolding (via+'cprDataStructureUnfolding_maybe'), and analyses that instead.  In practice, GHC generates a lot of (nested) TyCon and KindRep bindings, one-for each data declaration. It's wasteful to attach CPR signatures to each of-them (and intractable in case of Nested CPR).+for each data declaration. They should not have CPR signatures (blow up!). -Tracked by #18154.+There is a perhaps surprising special case: KindRep bindings satisfy+'isDataStructure' (so no CPR signature), but are marked NOINLINE at the same+time (see the noinline wrinkle in Note [Grand plan for Typeable]). So there is+no unfolding for 'cprDataStructureUnfolding_maybe' to look through and we'll+return topCprType. And that is fine! We should refrain to look through NOINLINE+data structures in general, as a constructed product could never be exposed+after WW.++It's also worth pointing out how ad-hoc this is: If we instead had++    f1 x = x:[]+    f2 x = x : f1 x+    f3 x = x : f2 x+    ...++we still give every function an every deepening CPR signature. But it's very+uncommon to find code like this, whereas the long static data structures from+the beginning of this Note are very common because of GHC's strategy of ANF'ing+data structure RHSs.  Note [CPR examples] ~~~~~~~~~~~~~~~~~~~~

@@ -23,6 +23,7 @@ import GHC.Core.Seq     ( seqBinds ) import GHC.Utils.Outputable import GHC.Types.Var.Env+import GHC.Types.Var.Set import GHC.Types.Basic import Data.List        ( mapAccumL ) import GHC.Core.DataCon@@ -32,6 +33,7 @@ import GHC.Core.Utils import GHC.Core.TyCon import GHC.Core.Type+import GHC.Core.FVs      ( exprFreeIds, ruleRhsFreeIds ) import GHC.Core.Coercion ( Coercion, coVarsOfCo ) import GHC.Core.FamInstEnv import GHC.Utils.Misc@@ -329,6 +331,10 @@     body_ty2 `seq`     (body_ty2,  Let (Rec pairs') body') +deleteFVs :: DmdType -> [Var] -> DmdType+deleteFVs (DmdType fvs dmds res) bndrs+  = DmdType (delVarEnvList fvs bndrs) dmds res+ -- | A simple, syntactic analysis of whether an expression MAY throw a precise -- exception when evaluated. It's always sound to return 'True'. -- See Note [Which scrutinees may throw precise exceptions].@@ -550,7 +556,9 @@             -- See Note [Demand signatures are computed for a threshold demand based on idArity]             = mkRhsDmd env rhs_arity rhs -    (DmdType rhs_fv rhs_dmds rhs_div, rhs') = dmdAnal env rhs_dmd rhs+    (rhs_dmd_ty, rhs') = dmdAnal env rhs_dmd rhs+    DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty+     sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div)      -- See Note [Aggregated demand for cardinality]@@ -558,10 +566,23 @@                 Just bs -> reuseEnv (delVarEnvList rhs_fv bs)                 Nothing -> rhs_fv +    rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` extra_fvs+     -- See Note [Lazy and unleashable free variables]-    (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1+    (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv2     is_thunk = not (exprIsHNF rhs) && not (isJoinId id) +    -- Find the RHS free vars of the unfoldings and RULES+    -- See Note [Absence analysis for stable unfoldings and RULES]+    extra_fvs = foldr (unionVarSet . ruleRhsFreeIds) unf_fvs $+                idCoreRules id++    unf = realIdUnfolding id+    unf_fvs | isStableUnfolding unf+            , Just unf_body <- maybeUnfoldingTemplate unf+            = exprFreeIds unf_body+            | otherwise = emptyVarSet+ -- | @mkRhsDmd env rhs_arity rhs@ creates a 'CleanDemand' for -- unleashing on the given function's @rhs@, by creating -- a call demand of @rhs_arity@@@ -797,7 +818,44 @@ forward plusInt's demand signature, and all is well (see Note [Newtype arity] in GHC.Core.Opt.Arity)! A small example is the test case NewtypeArity. +Note [Absence analysis for stable unfoldings and RULES]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Ticket #18638 shows that it's really important to do absence analysis+for stable unfoldings. Consider +   g = blah++   f = \x.  ...no use of g....+   {- f's stable unfolding is f = \x. ...g... -}++If f is ever inlined we use 'g'. But f's current RHS makes no use+of 'g', so if we don't look at the unfolding we'll mark g as Absent,+and transform to++   g = error "Entered absent value"+   f = \x. ...+   {- f's stable unfolding is f = \x. ...g... -}++Now if f is subsequently inlined, we'll use 'g' and ... disaster.++SOLUTION: if f has a stable unfolding, adjust its DmdEnv (the demands+on its free variables) so that no variable mentioned in its unfolding+is Absent.  This is done by the function Demand.keepAliveDmdEnv.++ALSO: do the same for Ids free in the RHS of any RULES for f.++PS: You may wonder how it can be that f's optimised RHS has somehow+discarded 'g', but when f is inlined we /don't/ discard g in the same+way. I think a simple example is+   g = (a,b)+   f = \x.  fst g+   {-# INLINE f #-}++Now f's optimised RHS will be \x.a, but if we change g to (error "..")+(since it is apparently Absent) and then inline (\x. fst g) we get+disaster.  But regardless, #18638 was a more complicated version of+this, that actually happened in practice.+ Historical Note [Product demands for function body] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In 2013 I spotted this example, in shootout/binary_trees:@@ -1018,9 +1076,12 @@ -}  setBndrsDemandInfo :: [Var] -> [Demand] -> [Var]-setBndrsDemandInfo (b:bs) (d:ds)-  | isTyVar b = b : setBndrsDemandInfo bs (d:ds)-  | otherwise = setIdDemandInfo b d : setBndrsDemandInfo bs ds+setBndrsDemandInfo (b:bs) ds+  | isTyVar b = b : setBndrsDemandInfo bs ds+setBndrsDemandInfo (b:bs) (d:ds) =+    let !new_info = setIdDemandInfo b d+        !vars = setBndrsDemandInfo bs ds+    in new_info : vars setBndrsDemandInfo [] ds = ASSERT( null ds ) [] setBndrsDemandInfo bs _  = pprPanic "setBndrsDemandInfo" (ppr bs) @@ -1059,46 +1120,16 @@     main_ty = addDemand dmd dmd_ty'     (dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id -deleteFVs :: DmdType -> [Var] -> DmdType-deleteFVs (DmdType fvs dmds res) bndrs-  = DmdType (delVarEnvList fvs bndrs) dmds res--{--Note [NOINLINE and strictness]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The strictness analyser used to have a HACK which ensured that NOINLNE-things were not strictness-analysed.  The reason was unsafePerformIO.-Left to itself, the strictness analyser would discover this strictness-for unsafePerformIO:-        unsafePerformIO:  C(U(AV))-But then consider this sub-expression-        unsafePerformIO (\s -> let r = f x in-                               case writeIORef v r s of (# s1, _ #) ->-                               (# s1, r #)-The strictness analyser will now find that r is sure to be eval'd,-and may then hoist it out.  This makes tests/lib/should_run/memo002-deadlock.--Solving this by making all NOINLINE things have no strictness info is overkill.-In particular, it's overkill for runST, which is perfectly respectable.-Consider-        f x = runST (return x)-This should be strict in x.--So the new plan is to define unsafePerformIO using the 'lazy' combinator:--        unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)+{- Note [NOINLINE and strictness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+At one point we disabled strictness for NOINLINE functions, on the+grounds that they should be entirely opaque.  But that lost lots of+useful semantic strictness information, so now we analyse them like+any other function, and pin strictness information on them. -Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is-magically NON-STRICT, and is inlined after strictness analysis.  So-unsafePerformIO will look non-strict, and that's what we want.+That in turn forces us to worker/wrapper them; see+Note [Worker-wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. -Now we don't need the hack in the strictness analyser.  HOWEVER, this-decision does mean that even a NOINLINE function is not entirely-opaque: some aspect of its implementation leaks out, notably its-strictness.  For example, if you have a function implemented by an-error stub, but which has RULES, you may want it not to be eliminated-in favour of error!  Note [Lazy and unleashable free variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -55,7 +55,7 @@ import GHC.Types.Basic import GHC.Utils.Monad  ( mapAccumLM, liftIO ) import GHC.Types.Var    ( isTyCoVar )-import GHC.Data.Maybe   ( orElse )+import GHC.Data.Maybe   ( orElse, isNothing ) import Control.Monad import GHC.Utils.Outputable import GHC.Data.FastString@@ -3288,7 +3288,8 @@     (StrictArg { sc_fun = fun, sc_cont = cont                , sc_fun_ty = fun_ty })   -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable-  | thumbsUpPlanA cont+  | isNothing (isDataConId_maybe (ai_fun fun))+  , thumbsUpPlanA cont  -- See point (3) of Note [Duplicating join points]   = -- Use Plan A of Note [Duplicating StrictArg]     do { let (_ : dmds) = ai_dmds fun        ; (floats1, cont')  <- mkDupableContWithDmds env dmds cont@@ -3398,7 +3399,7 @@ mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType                     -> SimplM (SimplFloats, SimplCont) mkDupableStrictBind env arg_bndr join_rhs res_ty-  | exprIsDupable (targetPlatform (seDynFlags env)) join_rhs+  | exprIsTrivial join_rhs   -- See point (2) of Note [Duplicating join points]   = return (emptyFloats env            , StrictBind { sc_bndr = arg_bndr, sc_bndrs = []                         , sc_body = join_rhs@@ -3425,8 +3426,8 @@ mkDupableAlt :: Platform -> OutId              -> JoinFloats -> OutAlt              -> SimplM (JoinFloats, OutAlt)-mkDupableAlt platform case_bndr jfloats (con, bndrs', rhs')-  | exprIsDupable platform rhs'  -- Note [Small alternative rhs]+mkDupableAlt _platform case_bndr jfloats (con, bndrs', rhs')+  | exprIsTrivial rhs'   -- See point (2) of Note [Duplicating join points]   = return (jfloats, (con, bndrs', rhs'))    | otherwise@@ -3508,8 +3509,83 @@  See #4957 a fuller example. -Note [Case binders and join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Duplicating join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+IN #19996 we discovered that we want to be really careful about+inlining join points.   Consider+    case (join $j x = K f x )+         (in case v of      )+         (     p1 -> $j x1  ) of+         (     p2 -> $j x2  )+         (     p3 -> $j x3  )+      K g y -> blah[g,y]++Here the join-point RHS is very small, just a constructor+application (K x y).  So we might inline it to get+    case (case v of        )+         (     p1 -> K f x1  ) of+         (     p2 -> K f x2  )+         (     p3 -> K f x3  )+      K g y -> blah[g,y]++But now we have to make `blah` into a join point, /abstracted/+over `g` and `y`.   In contrast, if we /don't/ inline $j we+don't need a join point for `blah` and we'll get+    join $j x = let g=f, y=x in blah[g,y]+    in case v of+       p1 -> $j x1+       p2 -> $j x2+       p3 -> $j x3++This can make a /massive/ difference, because `blah` can see+what `f` is, instead of lambda-abstracting over it.++To achieve this:++1. Do not postInlineUnconditionally a join point, until the Final+   phase.  (The Final phase is still quite early, so we might consider+   delaying still more.)++2. In mkDupableAlt and mkDupableStrictBind, generate an alterative for+   all alternatives, except for exprIsTrival RHSs. Previously we used+   exprIsDupable.  This generates a lot more join points, but makes+   them much more case-of-case friendly.++   It is definitely worth checking for exprIsTrivial, otherwise we get+   an extra Simplifier iteration, because it is inlined in the next+   round.++3. By the same token we want to use Plan B in+   Note [Duplicating StrictArg] when the RHS of the new join point+   is a data constructor application.  That same Note explains why we+   want Plan A when the RHS of the new join point would be a+   non-data-constructor application++4. You might worry that $j will be inlined by the call-site inliner,+   but it won't because the call-site context for a join is usually+   extremely boring (the arguments come from the pattern match).+   And if not, then perhaps inlining it would be a good idea.++   You might also wonder if we get UnfWhen, because the RHS of the+   join point is no bigger than the call. But in the cases we care+   about it will be a little bigger, because of that free `f` in+       $j x = K f x+   So for now we don't do anything special in callSiteInline++There is a bit of tension between (2) and (3).  Do we want to retain+the join point only when the RHS is+* a constructor application? or+* just non-trivial?+Currently, a bit ad-hoc, but we definitely want to retain the join+point for data constructors in mkDupalbleALt (point 2); that is the+whole point of #19996 described above.++Historical Note [Case binders and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB: this entire Note is now irrelevant.  In Jun 21 we stopped+adding unfoldings to lambda binders (#17530).  It was always a+hack and bit us in multiple small and not-so-small ways+ Consider this    case (case .. ) of c {      I# c# -> ....c....@@ -3558,24 +3634,6 @@ but zapping it (as we do in mkDupableCont, the Select case) is safe, and at worst delays the join-point inlining. -Note [Small alternative rhs]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It is worth checking for a small RHS because otherwise we-get extra let bindings that may cause an extra iteration of the simplifier to-inline back in place.  Quite often the rhs is just a variable or constructor.-The Ord instance of Maybe in PrelMaybe.hs, for example, took several extra-iterations because the version with the let bindings looked big, and so wasn't-inlined, but after the join points had been inlined it looked smaller, and so-was inlined.--NB: we have to check the size of rhs', not rhs.-Duplicating a small InAlt might invalidate occurrence information-However, if it *is* dupable, we return the *un* simplified alternative,-because otherwise we'd need to pair it up with an empty subst-env....-but we only have one env shared between all the alts.-(Remember we must zap the subst-env before re-simplifying something).-Rather than do this we simply agree to re-simplify the original (small) thing later.- Note [Funky mkLamTypes] ~~~~~~~~~~~~~~~~~~~~~~ Notice the funky mkLamTypes.  If the constructor has existentials@@ -3621,10 +3679,18 @@      join $j x = f e1 x e3      in case x of { True  -> jump $j r1                   ; False -> jump $j r2 }-  Notice that Plan B is very like the way we handle strict-  bindings; see Note [Duplicating StrictBind]. -Plan A is good. Here's an example from #3116+  Notice that Plan B is very like the way we handle strict bindings;+  see Note [Duplicating StrictBind].  And Plan B is exactly what we'd+  get if we turned use a case expression to evaluate the strict arg:++       case (case x of { True -> r1; False -> r2 }) of+         r -> f e1 r e3++  So, looking at Note [Duplicating join points], we also want Plan B+  when `f` is a data constructor.++Plan A is often good. Here's an example from #3116      go (n+1) (case l of                  1  -> bs'                  _  -> Chunk p fpc (o+1) (l-1) bs')@@ -3782,7 +3848,7 @@ ------------------- mkLetUnfolding :: DynFlags -> TopLevelFlag -> UnfoldingSource                -> InId -> OutExpr -> SimplM Unfolding-mkLetUnfolding dflags top_lvl src id new_rhs+mkLetUnfolding !dflags top_lvl src id new_rhs   = is_bottoming `seq`  -- See Note [Force bottoming field]     return (mkUnfolding dflags src is_top_lvl is_bottoming new_rhs)             -- We make an  unfolding *even for loop-breakers*.@@ -3792,8 +3858,11 @@             --             to expose.  (We could instead use the RHS, but currently             --             we don't.)  The simple thing is always to have one.   where-    is_top_lvl   = isTopLevel top_lvl-    is_bottoming = isDeadEndId id+    -- Might as well force this, profiles indicate up to 0.5MB of thunks+    -- just from this site.+    !is_top_lvl   = isTopLevel top_lvl+    -- See Note [Force bottoming field]+    !is_bottoming = isDeadEndId id  ------------------- simplStableUnfolding :: SimplEnv -> TopLevelFlag@@ -3830,11 +3899,17 @@                           , ug_boring_ok = boring_ok                           }                           -- Happens for INLINE things-                     -> let guide' =+                        -- Really important to force new_boring_ok as otherwise+                        -- `ug_boring_ok` is a thunk chain of+                        -- inlineBoringExprOk expr0+                        --  || inlineBoringExprOk expr1 || ...+                        --  See #20134+                     -> let !new_boring_ok = boring_ok || inlineBoringOk expr'+                            guide' =                               UnfWhen { ug_arity = arity                                       , ug_unsat_ok = sat_ok-                                      , ug_boring_ok =-                                          boring_ok || inlineBoringOk expr'+                                      , ug_boring_ok = new_boring_ok+                                       }                         -- Refresh the boring-ok flag, in case expr'                         -- has got small. This happens, notably in the inlinings@@ -3855,7 +3930,9 @@         | otherwise -> return noUnfolding   -- Discard unstable unfoldings   where     dflags     = seDynFlags env-    is_top_lvl = isTopLevel top_lvl+    -- Forcing this can save about 0.5MB of max residency and the result+    -- is small and easy to compute so might as well force it.+    !is_top_lvl = isTopLevel top_lvl     act        = idInlineActivation id     unf_env    = updMode (updModeForStableUnfoldings act) env          -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils

@@ -1361,6 +1361,8 @@   | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally]   | isTopLevel top_lvl          = False -- Note [Top level and postInlineUnconditionally]   | exprIsTrivial rhs           = True+  | isJoinId bndr                       -- See point (1) of Note [Duplicating join points]+  , not (phase == FinalPhase)   = False -- in Simplify.hs   | otherwise   = case occ_info of       OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt, occ_n_br = n_br }@@ -1415,7 +1417,8 @@   where     unfolding = idUnfolding bndr     dflags    = seDynFlags env-    active    = isActive (sm_phase (getMode env)) (idInlineActivation bndr)+    phase     = sm_phase (getMode env)+    active    = isActive phase (idInlineActivation bndr)         -- See Note [pre/postInlineUnconditionally in gentle mode]  {- Note [Inline small things to avoid creating a thunk]

@@ -357,7 +357,7 @@ -}    = schemeR_wrk fvs nm rhs (collect rhs) --- If an expression is a lambda (after apply bcView), return the+-- If an expression is a lambda, return the -- list of arguments to the lambda (in R-to-L order) and the -- underlying expression collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet)

@@ -47,7 +47,6 @@ import GHC.Types.Demand    ( isUsedOnce ) import GHC.Builtin.PrimOps ( PrimCall(..) ) import GHC.Types.SrcLoc    ( mkGeneralSrcSpan )-import GHC.Builtin.Names   ( unsafeEqualityProofName )  import Data.List.NonEmpty (nonEmpty, toList) import Data.Maybe    (fromMaybe)@@ -255,12 +254,13 @@ coreTopBindsToStg _      _        env ccs []   = (env, ccs, []) coreTopBindsToStg dflags this_mod env ccs (b:bs)+  | NonRec _ rhs <- b, isTyCoArg rhs+  = coreTopBindsToStg dflags this_mod env1 ccs1 bs+  | otherwise   = (env2, ccs2, b':bs')   where-        (env1, ccs1, b' ) =-          coreTopBindToStg dflags this_mod env ccs b-        (env2, ccs2, bs') =-          coreTopBindsToStg dflags this_mod env1 ccs1 bs+    (env1, ccs1, b' ) = coreTopBindToStg dflags this_mod env ccs b+    (env2, ccs2, bs') = coreTopBindsToStg dflags this_mod env1 ccs1 bs  coreTopBindToStg         :: DynFlags@@ -417,6 +417,7 @@  -- Cases require a little more real work. +{- coreToStgExpr (Case scrut _ _ [])   = coreToStgExpr scrut     -- See Note [Empty case alternatives] in GHC.Core If the case@@ -428,25 +429,20 @@     -- code generator, and put a return point anyway that calls a     -- runtime system error function. --coreToStgExpr e0@(Case scrut bndr _ alts) = do-    alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)-    scrut2 <- coreToStgExpr scrut-    let stg = StgCase scrut2 bndr (mkStgAltType bndr alts) alts2+coreToStgExpr e0@(Case scrut bndr _ [alt]) = do+  | isUnsafeEqualityProof scrut+  , isDeadBinder bndr -- We can only discard the case if the case-binder is dead+                      -- It usually is, but see #18227+  , (_,_,rhs) <- alt+  = coreToStgExpr rhs     -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce-    case scrut2 of-      StgApp id [] | idName id == unsafeEqualityProofName-                   , isDeadBinder bndr ->-        -- We can only discard the case if the case-binder is dead-        -- It usually is, but see #18227-        case alts2 of-          [(_, [_co], rhs)] ->-            return rhs-          _ ->-            pprPanic "coreToStgExpr" $-              text "Unexpected unsafe equality case expression:" $$ ppr e0 $$-              text "STG:" $$ pprStgExpr panicStgPprOpts stg-      _ -> return stg+-}++-- The normal case for case-expressions+coreToStgExpr (Case scrut bndr _ alts)+  = do { scrut2 <- coreToStgExpr scrut+       ; alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)+       ; return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2) }   where     vars_alt :: (AltCon, [Var], CoreExpr) -> CtsM (AltCon, [Var], StgExpr)     vars_alt (con, binders, rhs)@@ -628,25 +624,24 @@          -> CoreExpr     -- body          -> CtsM StgExpr -- new let -coreToStgLet bind body = do-    (bind2, body2)-       <- do+coreToStgLet bind body+  | NonRec _ rhs <- bind, isTyCoArg rhs+  = coreToStgExpr body -          ( bind2, env_ext)-                <- vars_bind bind+  | otherwise+  = do { (bind2, env_ext) <- vars_bind bind            -- Do the body-          extendVarEnvCts env_ext $ do-             body2 <- coreToStgExpr body--             return (bind2, body2)+         ; body2 <- extendVarEnvCts env_ext $+                    coreToStgExpr body          -- Compute the new let-expression-    let-        new_let | isJoinBind bind = StgLetNoEscape noExtFieldSilent bind2 body2-                | otherwise       = StgLet noExtFieldSilent bind2 body2+        ; let new_let | isJoinBind bind+                      = StgLetNoEscape noExtFieldSilent bind2 body2+                      | otherwise+                      = StgLet noExtFieldSilent bind2 body2 -    return new_let+        ; return new_let }   where     mk_binding binder rhs         = (binder, LetBound NestedLet (manifestArity rhs))

@@ -40,6 +40,7 @@ import GHC.Core.Coercion import GHC.Tc.Utils.Env import GHC.Core.TyCon+import GHC.Core.TyCo.Rep( UnivCoProvenance(..) ) import GHC.Types.Demand import GHC.Types.Var import GHC.Types.Var.Set@@ -61,9 +62,11 @@ import GHC.Data.FastString import GHC.Types.Name   ( NamedThing(..), nameSrcSpan, isInternalName ) import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )+import GHC.Data.Pair import Data.Bits import GHC.Utils.Monad  ( mapAccumLM ) import Data.List        ( unfoldr )+import Data.Functor.Identity import Control.Monad import GHC.Types.CostCentre ( CostCentre, ccFromThisModule ) import qualified Data.Set as S@@ -130,11 +133,59 @@     profiling mode. We have to do this here beucase we won't have unfoldings     after this pass (see `zapUnfolding` and Note [Drop unfoldings and rules]. +13. Eliminate case clutter in favour of unsafe coercions.+    See Note [Unsafe coercions]++14. Eliminate some magic Ids, specifically+     runRW# (\s. e)  ==>  e[readWorldId/s]+             lazy e  ==>  e+         noinline e  ==>  e+     ToDo:  keepAlive# ...+    This is done in cpeApp+ This is all done modulo type applications and abstractions, so that when type erasure is done for conversion to STG, we don't end up with any trivial or useless bindings. +Note [Unsafe coercions]+~~~~~~~~~~~~~~~~~~~~~~~+CorePrep does these two transformations: +* Convert empty case to cast with an unsafe coercion+          (case e of {}) ===>  e |> unsafe-co+  See Note [Empty case alternatives] in GHC.Core: if the case+  alternatives are empty, the scrutinee must diverge or raise an+  exception, so we can just dive into it.++  Of course, if the scrutinee *does* return, we may get a seg-fault.+  A belt-and-braces approach would be to persist empty-alternative+  cases to code generator, and put a return point anyway that calls a+  runtime system error function.++  Notice that eliminating empty case can lead to an ill-kinded coercion+      case error @Int "foo" of {}  :: Int#+      ===> error @Int "foo" |> unsafe-co+      where unsafe-co :: Int ~ Int#+  But that's fine because the expression diverges anyway. And it's+  no different to what happened before.++* Eliminate unsafeEqualityProof in favour of an unsafe coercion+          case unsafeEqualityProof of UnsafeRefl g -> e+          ===>  e[unsafe-co/g]+  See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce++  Note that this requiresuse ot substitute 'unsafe-co' for 'g', and+  that is the main (current) reason for cpe_tyco_env in CorePrepEnv.+  Tiresome, but not difficult.++These transformations get rid of "case clutter", leaving only casts.+We are doing no further significant tranformations, so the reasons+for the case forms have disappeared. And it is extremely helpful for+the ANF-ery, CoreToStg, and backends, if trivial expressions really do+look trivial. #19700 was an example.++In both cases, the "unsafe-co" is just (UnivCo ty1 ty2 CorePrepProv).+ Note [CorePrep invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is the syntax of the Core produced by CorePrep:@@ -366,6 +417,150 @@ (Since f is not considered to be free in its own RHS.)  +Note [keepAlive# magic]+~~~~~~~~~~~~~~~~~~~~~~~+When interacting with foreign code, it is often necessary for the user to+extend the lifetime of a heap object beyond the lifetime that would be apparent+from the on-heap references alone. For instance, a program like:++  foreign import safe "hello" hello :: ByteArray# -> IO ()++  callForeign :: IO ()+  callForeign = IO $ \s0 ->+    case newByteArray# n# s0 of (# s1, barr #) ->+      unIO hello barr s1++As-written this program is susceptible to memory-unsafety since there are+no references to `barr` visible to the garbage collector. Consequently, if a+garbage collection happens during the execution of the C function `hello`, it+may be that the array is freed while in use by the foreign function.++To address this, we introduced a new primop, keepAlive#, which "scopes over"+the computation needing the kept-alive value:++  keepAlive# :: forall (ra :: RuntimeRep) (rb :: RuntimeRep) (a :: TYPE a) (b :: TYPE b).+                a -> State# RealWorld -> (State# RealWorld -> b) -> b++When entered, an application (keepAlive# x s k) will apply `k` to the state+token, evaluating it to WHNF. However, during the course of this evaluation+will *guarantee* that `x` is considered to be alive.++There are a few things to note here:++ - we are RuntimeRep-polymorphic in the value to be kept-alive. This is+   necessary since we will often (but not always) be keeping alive something+   unlifted (like a ByteArray#)++ - we are RuntimeRep-polymorphic in the result value since the result may take+   many forms (e.g. a boxed value, a raw state token, or a (# State s, result #).++We implement this operation by desugaring to touch# during CorePrep (see+GHC.CoreToStg.Prep.cpeApp). Specifically,++  keepAlive# x s0 k++is transformed to:++  case k s0 of r ->+  case touch# x realWorld# of s1 ->+    r++Operationally, `keepAlive# x s k` is equivalent to pushing a stack frame with a+pointer to `x` and entering `k s0`. This compilation strategy is safe+because we do no optimization on STG that would drop or re-order the+continuation containing the `touch#`. However, if we were to become more+aggressive in our STG pipeline then we would need to revisit this.++Beyond this CorePrep transformation, there is very little special about+keepAlive#. However, we did explore (and eventually gave up on)+an optimisation which would allow unboxing of constructed product results,+which we describe below.+++Lost optimisation: CPR unboxing+--------------------------------+One unfortunate property of this approach is that the simplifier is unable to+unbox the result of a keepAlive# expression. For instance, consider the program:++  case keepAlive# arr s0 (+         \s1 -> case peekInt arr s1 of+                  (# s2, r #) -> I# r+  ) of+    I# x -> ...++This is a surprisingly common pattern, previously used, e.g., in+GHC.IO.Buffer.readWord8Buf. While exploring ideas, we briefly played around+with optimising this away by pushing strict contexts (like the+`case [] of I# x -> ...` above) into keepAlive#'s continuation. While this can+recover unboxing, it can also unfortunately in general change the asymptotic+memory (namely stack) behavior of the program. For instance, consider++  writeN =+    ...+      case keepAlive# x s0 (\s1 -> something s1) of+        (# s2, x #) ->+          writeN ...++As it is tail-recursive, this program will run in constant space. However, if+we push outer case into the continuation we get:++  writeN =++      case keepAlive# x s0 (\s1 ->+        case something s1 of+          (# s2, x #) ->+            writeN ...+      ) of+        ...++Which ends up building a stack which is linear in the recursion depth. For this+reason, we ended up giving up on this optimisation.+++Historical note: touch# and its inadequacy+------------------------------------------+Prior to the introduction of `keepAlive#` we instead addressed the need for+lifetime extension with the `touch#` primop:++    touch# :: a -> State# s -> State# s++This operation would ensure that the `a` value passed as the first argument was+considered "alive" at the time the primop application is entered.++For instance, the user might modify `callForeign` as:++  callForeign :: IO ()+  callForeign s0 = IO $ \s0 ->+    case newByteArray# n# s0 of (# s1, barr #) ->+    case unIO hello barr s1 of (# s2, () #) ->+    case touch# barr s2 of s3 ->+      (# s3, () #)++However, in #14346 we discovered that this primop is insufficient in the+presence of simplification. For instance, consider a program like:++  callForeign :: IO ()+  callForeign s0 = IO $ \s0 ->+    case newByteArray# n# s0 of (# s1, barr #) ->+    case unIO (forever $ hello barr) s1 of (# s2, () #) ->+    case touch# barr s2 of s3 ->+      (# s3, () #)++In this case the Simplifier may realize that (forever $ hello barr)+will never return and consequently that the `touch#` that follows is dead code.+As such, it will be dropped, resulting in memory unsoundness.+This unsoundness lead to the introduction of keepAlive#.++++Other related tickets:++ - #15544+ - #17760+ - #14375+ - #15260+ - #18061+ ************************************************************************ *                                                                      *                 The main code@@ -387,7 +582,7 @@                                    dmd is_unlifted                                    env bndr1 rhs        -- See Note [Inlining in CorePrep]-       ; let triv_rhs = cpExprIsTrivial rhs1+       ; let triv_rhs = exprIsTrivial rhs1              env2    | triv_rhs  = extendCorePrepEnvExpr env1 bndr rhs1                      | otherwise = env1              floats1 | triv_rhs, isInternalName (idName bndr)@@ -569,8 +764,10 @@ -- For example --      f (g x)   ===>   ([v = g x], f v) -cpeRhsE _env expr@(Type {})      = return (emptyFloats, expr)-cpeRhsE _env expr@(Coercion {})  = return (emptyFloats, expr)+cpeRhsE env (Type ty)+  = return (emptyFloats, Type (cpSubstTy env ty))+cpeRhsE env (Coercion co)+  = return (emptyFloats, Coercion (cpSubstCo env co)) cpeRhsE env expr@(Lit (LitNumber nt i))    = case cpe_convertNumLit env nt i of       Nothing -> return (emptyFloats, expr)@@ -603,7 +800,7 @@  cpeRhsE env (Cast expr co)    = do { (floats, expr') <- cpeRhsE env expr-        ; return (floats, Cast expr' co) }+        ; return (floats, Cast expr' (cpSubstCo env co)) }  cpeRhsE env expr@(Lam {})    = do { let (bndrs,body) = collectBinders expr@@ -611,19 +808,30 @@         ; body' <- cpeBodyNF env' body         ; return (emptyFloats, mkLams bndrs' body') } -cpeRhsE env (Case scrut bndr ty alts)+-- Eliminate empty case+-- See Note [Unsafe coercions]+cpeRhsE env (Case scrut _ ty [])+  = do { (floats, scrut') <- cpeRhsE env scrut+       ; let ty' = cpSubstTy env ty+             co' = mkUnsafeCo Representational (exprType scrut') ty'+       ; return (floats, Cast scrut' co') }+   -- This can give rise to+   --   Warning: Unsafe coercion: between unboxed and boxed value+   -- but it's fine because 'scrut' diverges++-- Eliminate unsafeEqualityProof+-- See Note [Unsafe coercions]+cpeRhsE env (Case scrut bndr _ alts)   | isUnsafeEqualityProof scrut-  , [(con, bs, rhs)] <- alts-  = do { (floats1, scrut') <- cpeBody env scrut-       ; (env1, bndr')     <- cpCloneBndr env bndr-       ; (env2, bs')       <- cpCloneBndrs env1 bs-       ; (floats2, rhs')   <- cpeBody env2 rhs-       ; let case_float = FloatCase scrut' bndr' con bs' True-             floats'    = (floats1 `addFloat` case_float)-                          `appendFloats` floats2-       ; return (floats', rhs') }+  , isDeadBinder bndr -- We can only discard the case if the case-binder+                      -- is dead.  It usually is, but see #18227+  , [(_, [co_var], rhs)] <- alts+  , let Pair ty1 ty2 = coVarTypes co_var+        the_co = mkUnsafeCo Nominal (cpSubstTy env ty1) (cpSubstTy env ty2)+        env'   = extendCoVarEnv env co_var the_co+  = cpeRhsE env' rhs -  | otherwise+cpeRhsE env (Case scrut bndr ty alts)   = do { (floats, scrut') <- cpeBody env scrut        ; (env', bndr2) <- cpCloneBndr env bndr        ; let alts'@@ -699,9 +907,9 @@   | all isTyVar bndrs           -- Type lambdas are ok   = return (emptyFloats, expr)   | otherwise                   -- Some value lambdas-  = do { fn <- newVar (exprType expr)-       ; let rhs   = cpeEtaExpand (exprArity expr) expr-             float = FloatLet (NonRec fn rhs)+  = do { let rhs = cpeEtaExpand (exprArity expr) expr+       ; fn <- newVar (exprType rhs)+       ; let float = FloatLet (NonRec fn rhs)        ; return (unitFloat float, Var fn) }   where     (bndrs,body) = collectBinders expr@@ -776,6 +984,7 @@         = let (terminal, args', depth') = collect_args arg           in cpe_app env terminal (args' ++ args) (depth + depth' - 1) +    -- See Note [keepAlive# magic].     cpe_app env             (Var f)             args@@ -789,7 +998,7 @@           : CpeApp s0           : CpeApp k           : rest <- args-        = do { y <- newVar result_ty+        = do { y  <- newVar (cpSubstTy env result_ty)              ; s2 <- newVar realWorldStatePrimTy              ; -- beta reduce if possible              ; (floats, k') <- case k of@@ -827,7 +1036,7 @@            -- Apps it is under are type applications only (c.f.            -- exprIsTrivial).  But note that we need the type of the            -- expression, not the id.-           ; (app, floats) <- rebuild_app args e2 (exprType e2) emptyFloats stricts+           ; (app, floats) <- rebuild_app env args e2 emptyFloats stricts            ; mb_saturate hd app floats depth }         where           stricts = case idStrictness v of@@ -847,13 +1056,11 @@          -- N-variable fun, better let-bind it     cpe_app env fun args depth-      = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty+      = do { (fun_floats, fun') <- cpeArg env evalDmd fun                           -- The evalDmd says that it's sure to be evaluated,                           -- so we'll end up case-binding it-           ; (app, floats) <- rebuild_app args fun' ty fun_floats []+           ; (app, floats) <- rebuild_app env args fun' fun_floats []            ; mb_saturate Nothing app floats depth }-        where-          ty = exprType fun      -- Saturate if necessary     mb_saturate head app floats depth =@@ -868,38 +1075,45 @@     -- all of which are used to possibly saturate this application if it     -- has a constructor or primop at the head.     rebuild_app-        :: [ArgInfo]                  -- The arguments (inner to outer)+        :: CorePrepEnv+        -> [ArgInfo]                  -- The arguments (inner to outer)         -> CpeApp-        -> Type         -> Floats         -> [Demand]         -> UniqSM (CpeApp, Floats)-    rebuild_app [] app _ floats ss = do-      MASSERT(null ss) -- make sure we used all the strictness info-      return (app, floats)-    rebuild_app (a : as) fun' fun_ty floats ss = case a of-      CpeApp arg@(Type arg_ty) ->-        rebuild_app as (App fun' arg) (piResultTy fun_ty arg_ty) floats ss-      CpeApp arg@(Coercion {}) ->-        rebuild_app as (App fun' arg) (funResultTy fun_ty) floats ss+    rebuild_app _ [] app floats ss+      = ASSERT(null ss) -- make sure we used all the strictness info+        return (app, floats)++    rebuild_app env (a : as) fun' floats ss = case a of++      CpeApp (Type arg_ty)+        -> rebuild_app env as (App fun' (Type arg_ty')) floats ss+        where+          arg_ty' = cpSubstTy env arg_ty++      CpeApp (Coercion co)+        -> rebuild_app env as (App fun' (Coercion co')) floats ss+        where+            co' = cpSubstCo env co+       CpeApp arg -> do         let (ss1, ss_rest)  -- See Note [lazyId magic] in GHC.Types.Id.Make                = case (ss, isLazyExpr arg) of                    (_   : ss_rest, True)  -> (topDmd, ss_rest)                    (ss1 : ss_rest, False) -> (ss1,    ss_rest)                    ([],            _)     -> (topDmd, [])-            (_, arg_ty, res_ty) =-              case splitFunTy_maybe fun_ty of-                Just as -> as-                Nothing -> pprPanic "cpeBody" (ppr fun_ty $$ ppr expr)-        (fs, arg') <- cpeArg top_env ss1 arg arg_ty-        rebuild_app as (App fun' arg') res_ty (fs `appendFloats` floats) ss_rest-      CpeCast co ->-        let ty2 = coercionRKind co-        in rebuild_app as (Cast fun' co) ty2 floats ss-      CpeTick tickish ->+        (fs, arg') <- cpeArg top_env ss1 arg+        rebuild_app env as (App fun' arg') (fs `appendFloats` floats) ss_rest++      CpeCast co+        -> rebuild_app env as (Cast fun' co') floats ss+        where+           co' = cpSubstCo env co++      CpeTick tickish         -- See [Floating Ticks in CorePrep]-        rebuild_app as fun' fun_ty (addFloat floats (FloatTick tickish)) ss+        -> rebuild_app env as fun' (addFloat floats (FloatTick tickish)) ss  isLazyExpr :: CoreExpr -> Bool -- See Note [lazyId magic] in GHC.Types.Id.Make@@ -1069,7 +1283,15 @@ treatment for runRW# applications, ensure the arguments are not floated as MFEs. +Now that we float evaluation context into runRW#, we also have to give runRW# a+special higher-order CPR transformer lest we risk #19822. E.g., +  case runRW# (\s -> doThings) of x -> Data.Text.Text x something something'+      ~>+  runRW# (\s -> case doThings s of x -> Data.Text.Text x something something')++The former had the CPR property, and so should the latter.+ Other considered designs ------------------------ @@ -1124,30 +1346,24 @@ floating done by cpeArg. -} +mkUnsafeCo :: Role -> Type -> Type -> Coercion+mkUnsafeCo role ty1 ty2 = mkUnivCo CorePrepProv role ty1 ty2+ -- | Is an argument okay to CPE? okCpeArg :: CoreExpr -> Bool -- Don't float literals. See Note [ANF-ising literal string arguments]. okCpeArg (Lit _) = False -- Do not eta expand a trivial argument-okCpeArg expr    = not (cpExprIsTrivial expr)--cpExprIsTrivial :: CoreExpr -> Bool-cpExprIsTrivial e-  | Tick t e <- e-  , not (tickishIsCode t)-  = cpExprIsTrivial e-  | Case scrut _ _ alts <- e-  , isUnsafeEqualityProof scrut-  , [(_,_,rhs)] <- alts-  = cpExprIsTrivial rhs-  | otherwise-  = exprIsTrivial e+okCpeArg expr    = not (exprIsTrivial expr)  -- This is where we arrange that a non-trivial argument is let-bound cpeArg :: CorePrepEnv -> Demand-       -> CoreArg -> Type -> UniqSM (Floats, CpeArg)-cpeArg env dmd arg arg_ty+       -> CoreArg -> UniqSM (Floats, CpeArg)+cpeArg env dmd arg   = do { (floats1, arg1) <- cpeRhsE env arg     -- arg1 can be a lambda+       ; let arg_ty      = exprType arg1+             is_unlifted = isUnliftedType arg_ty+             want_float  = wantFloatNested NonRecursive dmd is_unlifted        ; (floats2, arg2) <- if want_float floats1 arg1                             then return (floats1, arg1)                             else dontFloat floats1 arg1@@ -1161,9 +1377,6 @@                  ; return (addFloat floats2 arg_float, varToCoreExpr v) }          else return (floats2, arg2)        }-  where-    is_unlifted = isUnliftedType arg_ty-    want_float  = wantFloatNested NonRecursive dmd is_unlifted  {- Note [Floating unlifted arguments]@@ -1573,103 +1786,20 @@         --      see Note [lazyId magic], Note [Inlining in CorePrep]         --      and Note [CorePrep inlines trivial CoreExpr not Id] (#12076) +        , cpe_tyco_env :: Maybe CpeTyCoEnv -- See Note [CpeTyCoEnv]+         , cpe_convertNumLit   :: LitNumType -> Integer -> Maybe CoreExpr         -- ^ Convert some numeric literals (Integer, Natural) into their         -- final Core form     } --- | Create a function that converts Bignum literals into their final CoreExpr-mkConvertNumLiteral-   :: HscEnv-   -> IO (LitNumType -> Integer -> Maybe CoreExpr)-mkConvertNumLiteral hsc_env = do-   let-      dflags   = hsc_dflags hsc_env-      platform = targetPlatform dflags-      guardBignum act-         | homeUnitId dflags == primUnitId-         = return $ panic "Bignum literals are not supported in ghc-prim"-         | homeUnitId dflags == bignumUnitId-         = return $ panic "Bignum literals are not supported in ghc-bignum"-         | otherwise = act--      lookupBignumId n      = guardBignum (tyThingId <$> lookupGlobal hsc_env n)--   -- The lookup is done here but the failure (panic) is reported lazily when we-   -- try to access the `bigNatFromWordList` function.-   ---   -- If we ever get built-in ByteArray# literals, we could avoid the lookup by-   -- directly using the Integer/Natural wired-in constructors for big numbers.--   bignatFromWordListId <- lookupBignumId bignatFromWordListName--   let-      convertNumLit nt i = case nt of-         LitNumInteger -> Just (convertInteger i)-         LitNumNatural -> Just (convertNatural i)-         _             -> Nothing--      convertInteger i-         | platformInIntRange platform i -- fit in a Int#-         = mkConApp integerISDataCon [Lit (mkLitInt platform i)]--         | otherwise -- build a BigNat and embed into IN or IP-         = let con = if i > 0 then integerIPDataCon else integerINDataCon-           in mkBigNum con (convertBignatPrim (abs i))--      convertNatural i-         | platformInWordRange platform i -- fit in a Word#-         = mkConApp naturalNSDataCon [Lit (mkLitWord platform i)]--         | otherwise --build a BigNat and embed into NB-         = mkBigNum naturalNBDataCon (convertBignatPrim i)--      -- we can't simply generate:-      ---      --    NB (bigNatFromWordList# [W# 10, W# 20])-      ---      -- using `mkConApp` because it isn't in ANF form. Instead we generate:-      ---      --    case bigNatFromWordList# [W# 10, W# 20] of ba { DEFAULT -> NB ba }-      ---      -- via `mkCoreApps`--      mkBigNum con ba = mkCoreApps (Var (dataConWorkId con)) [ba]--      convertBignatPrim i =-         let-            target    = targetPlatform dflags--            -- ByteArray# literals aren't supported (yet). Were they supported,-            -- we would use them directly. We would need to handle-            -- wordSize/endianness conversion between host and target-            -- wordSize  = platformWordSize platform-            -- byteOrder = platformByteOrder platform--            -- For now we build a list of Words and we produce-            -- `bigNatFromWordList# list_of_words`--            words = mkListExpr wordTy (reverse (unfoldr f i))-               where-                  f 0 = Nothing-                  f x = let low  = x .&. mask-                            high = x `shiftR` bits-                        in Just (mkConApp wordDataCon [Lit (mkLitWord platform low)], high)-                  bits = platformWordSizeInBits target-                  mask = 2 ^ bits - 1--         in mkApps (Var bignatFromWordListId) [words]---   return convertNumLit-- mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv mkInitialCorePrepEnv hsc_env = do    convertNumLit <- mkConvertNumLiteral hsc_env    return $ CPE       { cpe_dynFlags = hsc_dflags hsc_env       , cpe_env = emptyVarEnv+      , cpe_tyco_env = Nothing       , cpe_convertNumLit = convertNumLit       } @@ -1693,6 +1823,117 @@         Just exp -> exp  ------------------------------------------------------------------------------+--           CpeTyCoEnv+-- ---------------------------------------------------------------------------++{- Note [CpeTyCoEnv]+~~~~~~~~~~~~~~~~~~~~+The cpe_tyco_env :: Maybe CpeTyCoEnv field carries a substitution+for type and coercion varibles++* We need the coercion substitution to support the elimination of+  unsafeEqualityProof (see Note [Unsafe coercions])++* We need the type substitution in case one of those unsafe+  coercions occurs in the kind of tyvar binder (sigh)++We don't need an in-scope set because we don't clone any of these+binders at all, so no new capture can take place.++The cpe_tyco_env is almost always empty -- it only gets populated+when we get under an usafeEqualityProof.  Hence the Maybe CpeTyCoEnv,+which makes everything into a no-op in the common case.+-}++data CpeTyCoEnv = TCE TvSubstEnv CvSubstEnv++emptyTCE :: CpeTyCoEnv+emptyTCE = TCE emptyTvSubstEnv emptyCvSubstEnv++extend_tce_cv :: CpeTyCoEnv -> CoVar -> Coercion -> CpeTyCoEnv+extend_tce_cv (TCE tv_env cv_env) cv co+  = TCE tv_env (extendVarEnv cv_env cv co)++extend_tce_tv :: CpeTyCoEnv -> TyVar -> Type -> CpeTyCoEnv+extend_tce_tv (TCE tv_env cv_env) tv ty+  = TCE (extendVarEnv tv_env tv ty) cv_env++lookup_tce_cv :: CpeTyCoEnv -> CoVar -> Coercion+lookup_tce_cv (TCE _ cv_env) cv+  = case lookupVarEnv cv_env cv of+        Just co -> co+        Nothing -> mkCoVarCo cv++lookup_tce_tv :: CpeTyCoEnv -> TyVar -> Type+lookup_tce_tv (TCE tv_env _) tv+  = case lookupVarEnv tv_env tv of+        Just ty -> ty+        Nothing -> mkTyVarTy tv++extendCoVarEnv :: CorePrepEnv -> CoVar -> Coercion -> CorePrepEnv+extendCoVarEnv cpe@(CPE { cpe_tyco_env = mb_tce }) cv co+  = cpe { cpe_tyco_env = Just (extend_tce_cv tce cv co) }+  where+    tce = mb_tce `orElse` emptyTCE+++cpSubstTy :: CorePrepEnv -> Type -> Type+cpSubstTy (CPE { cpe_tyco_env = mb_env }) ty+  = case mb_env of+      Just env -> runIdentity (subst_ty env ty)+      Nothing  -> ty++cpSubstCo :: CorePrepEnv -> Coercion -> Coercion+cpSubstCo (CPE { cpe_tyco_env = mb_env }) co+  = case mb_env of+      Just tce -> runIdentity (subst_co tce co)+      Nothing  -> co++subst_tyco_mapper :: TyCoMapper CpeTyCoEnv Identity+subst_tyco_mapper = TyCoMapper+  { tcm_tyvar      = \env tv -> return (lookup_tce_tv env tv)+  , tcm_covar      = \env cv -> return (lookup_tce_cv env cv)+  , tcm_hole       = \_ hole -> pprPanic "subst_co_mapper:hole" (ppr hole)+  , tcm_tycobinder = \env tcv _vis -> if isTyVar tcv+                                      then return (subst_tv_bndr env tcv)+                                      else return (subst_cv_bndr env tcv)+  , tcm_tycon      = \tc -> return tc }++subst_ty :: CpeTyCoEnv -> Type     -> Identity Type+subst_co :: CpeTyCoEnv -> Coercion -> Identity Coercion+(subst_ty, _, subst_co, _) = mapTyCoX subst_tyco_mapper++cpSubstTyVarBndr :: CorePrepEnv -> TyVar -> (CorePrepEnv, TyVar)+cpSubstTyVarBndr env@(CPE { cpe_tyco_env = mb_env }) tv+  = case mb_env of+      Nothing  -> (env, tv)+      Just tce -> (env { cpe_tyco_env = Just tce' }, tv')+               where+                  (tce', tv') = subst_tv_bndr tce tv++subst_tv_bndr :: CpeTyCoEnv -> TyVar -> (CpeTyCoEnv, TyVar)+subst_tv_bndr tce tv+  = (extend_tce_tv tce tv (mkTyVarTy tv'), tv')+  where+    tv'   = mkTyVar (tyVarName tv) kind'+    kind' = runIdentity $ subst_ty tce $ tyVarKind tv++cpSubstCoVarBndr :: CorePrepEnv -> CoVar -> (CorePrepEnv, CoVar)+cpSubstCoVarBndr env@(CPE { cpe_tyco_env = mb_env }) cv+  = case mb_env of+      Nothing  -> (env, cv)+      Just tce -> (env { cpe_tyco_env = Just tce' }, cv')+               where+                  (tce', cv') = subst_cv_bndr tce cv++subst_cv_bndr :: CpeTyCoEnv -> CoVar -> (CpeTyCoEnv, CoVar)+subst_cv_bndr tce cv+  = (extend_tce_cv tce cv (mkCoVarCo cv'), cv')+  where+    cv' = mkCoVar (varName cv) ty'+    ty' = runIdentity (subst_ty tce $ varType cv)++------------------------------------------------------------------------------ -- Cloning binders -- --------------------------------------------------------------------------- @@ -1701,9 +1942,12 @@  cpCloneBndr  :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar) cpCloneBndr env bndr-  | not (isId bndr)-  = return (env, bndr)+  | isTyVar bndr+  = return (cpSubstTyVarBndr env bndr) +  | isCoVar bndr+  = return (cpSubstCoVarBndr env bndr)+   | otherwise   = do { bndr' <- clone_it bndr @@ -1719,11 +1963,13 @@        ; return (extendCorePrepEnv env bndr bndr'', bndr'') }   where     clone_it bndr-      | isLocalId bndr, not (isCoVar bndr)-      = do { uniq <- getUniqueM; return (setVarUnique bndr uniq) }+      | isLocalId bndr+      = do { uniq <- getUniqueM+           ; let ty' = cpSubstTy env (idType bndr)+           ; return (setVarUnique (setIdType bndr ty') uniq) }+       | otherwise   -- Top level things, which we don't want                     -- to clone, have become GlobalIds by now-                    -- And we don't clone tyvars, or coercion variables       = return bndr  {- Note [Drop unfoldings and rules]@@ -1856,3 +2102,94 @@     -- Unfoldings may have cost centres that in the original definion are     -- optimized away, see #5889.     get_unf = maybeUnfoldingTemplate . realIdUnfolding+++------------------------------------------------------------------------------+-- Numeric literals+-- ---------------------------------------------------------------------------++-- | Create a function that converts Bignum literals into their final CoreExpr+mkConvertNumLiteral+   :: HscEnv+   -> IO (LitNumType -> Integer -> Maybe CoreExpr)+mkConvertNumLiteral hsc_env = do+   let+      dflags   = hsc_dflags hsc_env+      platform = targetPlatform dflags+      guardBignum act+         | homeUnitId dflags == primUnitId+         = return $ panic "Bignum literals are not supported in ghc-prim"+         | homeUnitId dflags == bignumUnitId+         = return $ panic "Bignum literals are not supported in ghc-bignum"+         | otherwise = act++      lookupBignumId n      = guardBignum (tyThingId <$> lookupGlobal hsc_env n)++   -- The lookup is done here but the failure (panic) is reported lazily when we+   -- try to access the `bigNatFromWordList` function.+   --+   -- If we ever get built-in ByteArray# literals, we could avoid the lookup by+   -- directly using the Integer/Natural wired-in constructors for big numbers.++   bignatFromWordListId <- lookupBignumId bignatFromWordListName++   let+      convertNumLit nt i = case nt of+         LitNumInteger -> Just (convertInteger i)+         LitNumNatural -> Just (convertNatural i)+         _             -> Nothing++      convertInteger i+         | platformInIntRange platform i -- fit in a Int#+         = mkConApp integerISDataCon [Lit (mkLitInt platform i)]++         | otherwise -- build a BigNat and embed into IN or IP+         = let con = if i > 0 then integerIPDataCon else integerINDataCon+           in mkBigNum con (convertBignatPrim (abs i))++      convertNatural i+         | platformInWordRange platform i -- fit in a Word#+         = mkConApp naturalNSDataCon [Lit (mkLitWord platform i)]++         | otherwise --build a BigNat and embed into NB+         = mkBigNum naturalNBDataCon (convertBignatPrim i)++      -- we can't simply generate:+      --+      --    NB (bigNatFromWordList# [W# 10, W# 20])+      --+      -- using `mkConApp` because it isn't in ANF form. Instead we generate:+      --+      --    case bigNatFromWordList# [W# 10, W# 20] of ba { DEFAULT -> NB ba }+      --+      -- via `mkCoreApps`++      mkBigNum con ba = mkCoreApps (Var (dataConWorkId con)) [ba]++      convertBignatPrim i =+         let+            target    = targetPlatform dflags++            -- ByteArray# literals aren't supported (yet). Were they supported,+            -- we would use them directly. We would need to handle+            -- wordSize/endianness conversion between host and target+            -- wordSize  = platformWordSize platform+            -- byteOrder = platformByteOrder platform++            -- For now we build a list of Words and we produce+            -- `bigNatFromWordList# list_of_words`++            words = mkListExpr wordTy (reverse (unfoldr f i))+               where+                  f 0 = Nothing+                  f x = let low  = x .&. mask+                            high = x `shiftR` bits+                        in Just (mkConApp wordDataCon [Lit (mkLitWord platform low)], high)+                  bits = platformWordSizeInBits target+                  mask = 2 ^ bits - 1++         in mkApps (Var bignatFromWordListId) [words]+++   return convertNumLit+

@@ -0,0 +1,91 @@+{- Union-find data structure compiled from Distribution.Utils.UnionFind -}+module GHC.Data.UnionFind where++import GHC.Prelude+import Data.STRef+import Control.Monad.ST+import Control.Monad++-- | A variable which can be unified; alternately, this can be thought+-- of as an equivalence class with a distinguished representative.+newtype Point s a = Point (STRef s (Link s a))+    deriving (Eq)++-- | Mutable write to a 'Point'+writePoint :: Point s a -> Link s a -> ST s ()+writePoint (Point v) = writeSTRef v++-- | Read the current value of 'Point'.+readPoint :: Point s a -> ST s (Link s a)+readPoint (Point v) = readSTRef v++-- | The internal data structure for a 'Point', which either records+-- the representative element of an equivalence class, or a link to+-- the 'Point' that actually stores the representative type.+data Link s a+    -- NB: it is too bad we can't say STRef Int#; the weights remain boxed+    = Info {-# UNPACK #-} !(STRef s Int) {-# UNPACK #-} !(STRef s a)+    | Link {-# UNPACK #-} !(Point s a)++-- | Create a fresh equivalence class with one element.+fresh :: a -> ST s (Point s a)+fresh desc = do+    weight <- newSTRef 1+    descriptor <- newSTRef desc+    Point `fmap` newSTRef (Info weight descriptor)++-- | Flatten any chains of links, returning a 'Point'+-- which points directly to the canonical representation.+repr :: Point s a -> ST s (Point s a)+repr point = readPoint point >>= \r ->+  case r of+    Link point' -> do+        point'' <- repr point'+        when (point'' /= point') $ do+            writePoint point =<< readPoint point'+        return point''+    Info _ _ -> return point++-- | Return the canonical element of an equivalence+-- class 'Point'.+find :: Point s a -> ST s a+find point =+    -- Optimize length 0 and 1 case at expense of+    -- general case+    readPoint point >>= \r ->+      case r of+        Info _ d_ref -> readSTRef d_ref+        Link point' -> readPoint point' >>= \r' ->+          case r' of+            Info _ d_ref -> readSTRef d_ref+            Link _ -> repr point >>= find++-- | Unify two equivalence classes, so that they share+-- a canonical element. Keeps the descriptor of point2.+union :: Point s a -> Point s a -> ST s ()+union refpoint1 refpoint2 = do+    point1 <- repr refpoint1+    point2 <- repr refpoint2+    when (point1 /= point2) $ do+      l1 <- readPoint point1+      l2 <- readPoint point2+      case (l1, l2) of+          (Info wref1 dref1, Info wref2 dref2) -> do+              weight1 <- readSTRef wref1+              weight2 <- readSTRef wref2+              -- Should be able to optimize the == case separately+              if weight1 >= weight2+                  then do+                      writePoint point2 (Link point1)+                      -- The weight calculation here seems a bit dodgy+                      writeSTRef wref1 (weight1 + weight2)+                      writeSTRef dref1 =<< readSTRef dref2+                  else do+                      writePoint point1 (Link point2)+                      writeSTRef wref2 (weight1 + weight2)+          _ -> error "UnionFind.union: repr invariant broken"++-- | Test if two points are in the same equivalence class.+equivalent :: Point s a -> Point s a -> ST s Bool+equivalent point1 point2 = liftM2 (==) (repr point1) (repr point2)+

@@ -196,7 +196,7 @@ findLookupResult hsc_env r = case r of      LookupFound m pkg_conf -> do        let im = fst (getModuleInstantiation m)-       r' <- findPackageModule_ hsc_env im pkg_conf+       r' <- findPackageModule_ hsc_env im (fst pkg_conf)        case r' of         -- TODO: ghc -M is unlikely to do the right thing         -- with just the location of the thing that was

@@ -39,6 +39,7 @@     , Messager, batchMsg     , HscStatus (..)     , hscIncrementalCompile+    , initModDetails     , hscMaybeWriteIface     , hscCompileCmmFile @@ -181,6 +182,7 @@ import GHC.Iface.Ext.Types  ( getAsts, hie_asts, hie_module ) import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result, NameCacheUpdater(..)) import GHC.Iface.Ext.Debug  ( diffFile, validateScopes )+import Data.List.NonEmpty (NonEmpty ((:|)))  #include "GhclibHsVersions.h" @@ -347,6 +349,25 @@                Nothing -> liftIO $ hGetStringBuffer src_filename      let loc = mkRealSrcLoc (mkFastString src_filename) 1 1+    when (wopt Opt_WarnUnicodeBidirectionalFormatCharacters dflags) $ do+      case checkBidirectionFormatChars (PsLoc loc (BufPos 0)) buf of+        Nothing -> pure ()+        Just ((loc,chr,desc) :| xs) ->+          let span = mkSrcSpanPs $ mkPsSpan loc (advancePsLoc loc chr)+              warn = makeIntoWarning (Reason Opt_WarnUnicodeBidirectionalFormatCharacters) $ mkLongWarnMsg dflags span neverQualify msg empty+              msg = text "A unicode bidirectional formatting character" <+> parens (text desc)+                 $$ text "was found at offset" <+> ppr (bufPos (psBufPos loc)) <+> text "in the file"+                 $$ (case xs of+                       [] -> empty+                       xs -> text "along with further bidirectional formatting characters at" <+> pprChars xs+                        where+                          pprChars [] = empty+                          pprChars ((loc,_,desc):xs) = text "offset" <+> ppr (bufPos (psBufPos loc)) <> text ":" <+> text desc+                                                    $$ pprChars xs)+                 $$ text "Bidirectional formatting characters may be rendered misleadingly in certain editors"++          in liftIO $ printOrThrowWarnings dflags (unitBag warn)+     let parseMod | HsigFile == ms_hsc_src mod_summary                  = parseSignature                  | otherwise = parseModule@@ -408,9 +429,34 @@                   = parsedResultAction p opts mod_summary             withPlugins dflags applyPluginAction res +checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String))+checkBidirectionFormatChars start_loc sb+  | containsBidirectionalFormatChar sb = Just $ go start_loc sb+  | otherwise = Nothing+  where+    go :: PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, String)+    go loc sb+      | atEnd sb = panic "checkBidirectionFormatChars: no char found"+      | otherwise = case nextChar sb of+          (chr, sb)+            | Just desc <- lookup chr bidirectionalFormatChars ->+                (loc, chr, desc) :| go1 (advancePsLoc loc chr) sb+            | otherwise -> go (advancePsLoc loc chr) sb +    go1 :: PsLoc -> StringBuffer -> [(PsLoc, Char, String)]+    go1 loc sb+      | atEnd sb = []+      | otherwise = case nextChar sb of+          (chr, sb)+            | Just desc <- lookup chr bidirectionalFormatChars ->+                (loc, chr, desc) : go1 (advancePsLoc loc chr) sb+            | otherwise -> go1 (advancePsLoc loc chr) sb++ -- ----------------------------------------------------------------------------- -- | If the renamed source has been kept, extract it. Dump it if requested.++ extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff extract_renamed_stuff mod_summary tc_result = do     let rn_info = getRenamedStuff tc_result@@ -743,19 +789,7 @@         -- We didn't need to do any typechecking; the old interface         -- file on disk was good enough.         Left iface -> do-            -- Knot tying!  See Note [Knot-tying typecheckIface]-            details <- liftIO . fixIO $ \details' -> do-                let hsc_env' =-                        hsc_env {-                            hsc_HPT = addToHpt (hsc_HPT hsc_env)-                                        (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 details+            details <- liftIO $ initModDetails hsc_env mod_summary iface             return (HscUpToDate iface details, dflags)         -- We finished type checking.  (mb_old_hash is the hash of         -- the interface that existed on disk; it's possible we had@@ -765,6 +799,66 @@             status <- finish mod_summary tc_result mb_old_hash             return (status, dflags) +-- Knot tying!  See Note [Knot-tying typecheckIface]+-- See Note [ModDetails and --make mode]+initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails+initModDetails hsc_env mod_summary iface =+  fixIO $ \details' -> do+    let hsc_env' = hsc_env {+                    hsc_HPT = addToHpt (hsc_HPT hsc_env)+                                       (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.+    genModDetails hsc_env' iface+++{-+Note [ModDetails and --make mode]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++An interface file consists of two parts++* The `ModIface` which ends up getting written to disk.+  The `ModIface` is a completely acyclic tree, which can be serialised+  and de-serialised completely straightforwardly.  The `ModIface` is+  also the structure that is finger-printed for recompilation control.++* The `ModDetails` which provides a more structured view that is suitable+  for usage during compilation.  The `ModDetails` is heavily cyclic:+  An `Id` contains a `Type`, which mentions a `TyCon` that contains kind+  that mentions other `TyCons`; the `Id` also includes an unfolding that+  in turn mentions more `Id`s;  And so on.++The `ModIface` can be created from the `ModDetails` and the `ModDetails` from+a `ModIface`.++During tidying, just before interfaces are written to disk,+the ModDetails is calculated and then converted into a ModIface (see GHC.Iface.Make.mkIface_).+Then when GHC needs to restart typechecking from a certain point it can read the+interface file, and regenerate the ModDetails from the ModIface (see GHC.IfaceToCore.typecheckIface).+The key part about the loading is that the ModDetails is regenerated lazily+from the ModIface, so that there's only a detailed in-memory representation+for declarations which are actually used from the interface. This mode is+also used when reading interface files from external packages.++In the old --make mode implementation, the interface was written after compiling a module+but the in-memory ModDetails which was used to compute the ModIface was retained.+The result was that --make mode used much more memory than `-c` mode, because a large amount of+information about a module would be kept in the ModDetails but never used.++The new idea is that even in `--make` mode, when there is an in-memory `ModDetails`+at hand, we re-create the `ModDetails` from the `ModIface`. Doing this means that+we only have to keep the `ModIface` decls in memory and then lazily load+detailed representations if needed. It turns out this makes a really big difference+to memory usage, halving maximum memory used in some cases.++See !5492 and #13586+-}+ -- 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.@@ -817,7 +911,6 @@            return HscRecomp { hscs_guts = cg_guts,                              hscs_mod_location = ms_location summary,-                             hscs_mod_details = details,                              hscs_partial_iface = partial_iface,                              hscs_old_iface_hash = mb_old_hash,                              hscs_iface_dflags = dflags }

@@ -72,6 +72,7 @@ import GHC.Types.Name.Env import GHC.SysTools.FileCleanup + import Data.Either ( rights, partitionEithers ) import qualified Data.Map as Map import Data.Map (Map)@@ -142,7 +143,11 @@     (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots     if isEmptyBag errs       then do-        warnMissingHomeModules hsc_env mod_graph+        let unused_home_mod_err = warnMissingHomeModules hsc_env mod_graph+            unused_pkg_err = warnUnusedPackages hsc_env mod_graph+            warns = unused_home_mod_err ++ unused_pkg_err+        when (not $ null warns) $+          logWarnings (listToBag warns)         setSession hsc_env { hsc_mod_graph = mod_graph }         pure (errs, mod_graph)       else do@@ -206,10 +211,11 @@ -- about module "C" not being listed in a command line. -- -- The warning in enabled by `-Wmissing-home-modules`. See #13129-warnMissingHomeModules :: GhcMonad m => HscEnv -> ModuleGraph -> m ()+warnMissingHomeModules :: HscEnv -> ModuleGraph -> [ErrMsg] warnMissingHomeModules hsc_env mod_graph =-    when (wopt Opt_WarnMissingHomeModules dflags && not (null missing)) $-        logWarnings (listToBag [warn])+    if (wopt Opt_WarnMissingHomeModules dflags && not (null missing))+    then [warn]+    else []   where     dflags = hsc_dflags hsc_env     targets = map targetId (hsc_targets hsc_env)@@ -289,7 +295,6 @@ load how_much = do     (errs, mod_graph) <- depanalE [] False                        -- #17459     success <- load' how_much (Just batchMsg) mod_graph-    warnUnusedPackages     if isEmptyBag errs       then pure success       else throwErrors errs@@ -301,21 +306,15 @@ -- actually loaded packages. All the packages, specified on command line, -- but never loaded, are probably unused dependencies. -warnUnusedPackages :: GhcMonad m => m ()-warnUnusedPackages = do-    hsc_env <- getSession-    eps <- liftIO $ hscEPS hsc_env-+warnUnusedPackages :: HscEnv -> ModuleGraph -> [ErrMsg]+warnUnusedPackages hsc_env mod_graph =     let dflags = hsc_dflags hsc_env         state  = unitState dflags-        pit = eps_PIT eps -    let loadedPackages-          = map (unsafeLookupUnit state)-          . nub . sort-          . map moduleUnit-          . moduleEnvKeys-          $ pit+    -- Only need non-source imports here because SOURCE imports are always HPT+        loadedPackages = concat $+          mapMaybe (\(fs, mn) -> lookupModulePackage state (unLoc mn) fs)+            $ concatMap ms_imps (mgModSummaries mod_graph)          requestedArgs = mapMaybe packageArg (packageFlags dflags) @@ -323,7 +322,7 @@           = filter (\arg -> not $ any (matching state arg) loadedPackages)                    requestedArgs -    let warn = makeIntoWarning+        warn = makeIntoWarning           (Reason Opt_WarnUnusedPackages)           (mkPlainErrMsg dflags noSrcSpan msg)         msg = vcat [ text "The following packages were specified" <+>@@ -331,8 +330,9 @@                    , text "but were not needed for compilation:"                    , nest 2 (vcat (map (withDash . pprUnusedArg) unusedArgs)) ] -    when (wopt Opt_WarnUnusedPackages dflags && not (null unusedArgs)) $-      logWarnings (listToBag [warn])+    in if not (null unusedArgs) && wopt Opt_WarnUnusedPackages dflags+       then [warn]+       else []      where         packageArg (ExposePackage _ arg _) = Just arg

@@ -40,7 +40,7 @@ import System.FilePath import System.IO import System.IO.Error  ( isEOFError )-import Control.Monad    ( when )+import Control.Monad    ( when, forM_ ) import Data.Maybe       ( isJust ) import Data.IORef import qualified Data.Set as Set@@ -225,6 +225,16 @@                 -- Emit std dependency of the object(s) on the source file                 -- Something like       A.o : A.hs         ; writeDependency root hdl obj_files src_file++          -- add dependency between objects and their corresponding .hi-boot+          -- files if the module has a corresponding .hs-boot file (#14482)+        ; when (isBootSummary node == IsBoot) $ do+            let hi_boot = msHiFilePath node+            let obj     = removeBootSuffix (msObjFilePath node)+            forM_ extra_suffixes $ \suff -> do+               let way_obj     = insertSuffixes obj     [suff]+               let way_hi_boot = insertSuffixes hi_boot [suff]+               mapM_ (writeDependency root hdl way_obj) way_hi_boot                  -- Emit a dependency for each CPP import         ; when (depIncludeCppDeps dflags) $ do

@@ -71,7 +71,6 @@ import GHC.Data.Bag             ( unitBag ) import GHC.Data.FastString      ( mkFastString ) import GHC.Iface.Make           ( mkFullIface )-import GHC.Iface.UpdateIdInfos  ( updateModDetailsIdInfos )  import GHC.Utils.Exception as Exception import System.Directory@@ -226,13 +225,16 @@             return $! HomeModInfo iface hmi_details (Just linkable)         (HscRecomp { hscs_guts = cgguts,                      hscs_mod_location = mod_location,-                     hscs_mod_details = hmi_details,                      hscs_partial_iface = partial_iface,                      hscs_old_iface_hash = mb_old_iface_hash,                      hscs_iface_dflags = iface_dflags }, HscInterpreted) -> do             -- In interpreted mode the regular codeGen backend is not run so we             -- generate a interface without codeGen info.-            final_iface <- mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface Nothing+            let hsc_env'' = hsc_env'{hsc_dflags=iface_dflags}+            final_iface <- mkFullIface hsc_env'' partial_iface Nothing+            -- Reconstruct the `ModDetails` from the just-constructed `ModIface`+            -- See Note [ModDetails and --make mode]+            hmi_details <- liftIO $ initModDetails hsc_env'' summary final_iface             liftIO $ hscMaybeWriteIface dflags final_iface mb_old_iface_hash (ms_location summary)              (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cgguts mod_location@@ -259,7 +261,7 @@                             (Temporary TFL_CurrentModule)                             basename dflags next_phase (Just location)             -- We're in --make mode: finish the compilation pipeline.-            (_, _, Just (iface, details)) <- runPipeline StopLn hsc_env'+            (_, _, Just iface) <- runPipeline StopLn hsc_env'                               (output_fn,                                Nothing,                                Just (HscOut src_flavour mod_name status))@@ -270,6 +272,8 @@                   -- The object filename comes from the ModLocation             o_time <- getModificationUTCTime object_filename             let !linkable = LM o_time this_mod [DotO object_filename]+            -- See Note [ModDetails and --make mode]+            details <- initModDetails hsc_env' summary iface             return $! HomeModInfo iface details (Just linkable)   where dflags0     = ms_hspp_opts summary@@ -312,7 +316,7 @@        old_paths   = includePaths dflags2        !prevailing_dflags = hsc_dflags hsc_env0        dflags =-          dflags2 { includePaths = addQuoteInclude old_paths [current_dir]+          dflags2 { includePaths = addImplicitQuoteInclude old_paths [current_dir]                   , log_action = log_action prevailing_dflags }                   -- use the prevailing log_action / log_finaliser,                   -- not the one cached in the summary.  This is so@@ -661,7 +665,7 @@   -> PipelineOutput             -- ^ Output filename   -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module   -> [FilePath]                 -- ^ foreign objects-  -> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))+  -> IO (DynFlags, FilePath, Maybe ModIface)                                 -- ^ (final flags, output filename, interface) runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase)              mb_basename output maybe_loc foreign_os@@ -756,7 +760,7 @@   -> FilePath                   -- ^ Input filename   -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module   -> [FilePath]                 -- ^ foreign objects, if we have one-  -> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))+  -> IO (DynFlags, FilePath, Maybe ModIface)                                 -- ^ (final flags, output filename, interface) runPipeline' start_phase hsc_env env input_fn              maybe_loc foreign_os@@ -1099,7 +1103,7 @@   -- the .hs files resides) to the include path, since this is   -- what gcc does, and it's probably what you want.         let current_dir = takeDirectory basename-            new_includes = addQuoteInclude paths [current_dir]+            new_includes = addImplicitQuoteInclude paths [current_dir]             paths = includePaths dflags0             dflags = dflags0 { includePaths = new_includes } @@ -1221,7 +1225,6 @@                    return (RealPhase StopLn, o_file)             HscRecomp { hscs_guts = cgguts,                         hscs_mod_location = mod_location,-                        hscs_mod_details = mod_details,                         hscs_partial_iface = partial_iface,                         hscs_old_iface_hash = mb_old_iface_hash,                         hscs_iface_dflags = iface_dflags }@@ -1233,9 +1236,7 @@                       hscGenHardCode hsc_env' cgguts mod_location output_fn                      final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface (Just cg_infos))-                    let final_mod_details = {-# SCC updateModDetailsIdInfos #-}-                                            updateModDetailsIdInfos iface_dflags cg_infos mod_details-                    setIface final_iface final_mod_details+                    setIface final_iface                      -- See Note [Writing interface files]                     let if_dflags = dflags `gopt_unset` Opt_BuildDynamicToo@@ -1286,7 +1287,8 @@         let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []               (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)         let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []-              (includePathsQuote cmdline_include_paths)+              (includePathsQuote cmdline_include_paths +++               includePathsQuoteImplicit cmdline_include_paths)         let include_paths = include_paths_quote ++ include_paths_global          -- pass -D or -optP to preprocessor when compiling foreign C files@@ -1423,7 +1425,8 @@         let global_includes = [ GHC.SysTools.Option ("-I" ++ p)                               | p <- includePathsGlobal cmdline_include_paths ]         let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p)-                             | p <- includePathsQuote cmdline_include_paths ]+                             | p <- includePathsQuote cmdline_include_paths +++                                includePathsQuoteImplicit cmdline_include_paths]         let runAssembler inputFilename outputFilename               = liftIO $ do                   withAtomicRename outputFilename $ \temp_outputFilename -> do@@ -1728,7 +1731,7 @@                                  (l `makeRelativeTo` full_output_fn)                             else l                   -- See Note [-Xlinker -rpath vs -Wl,-rpath]-                  rpath = if gopt Opt_RPath dflags+                  rpath = if useXLinkerRPath dflags (platformOS platform)                           then ["-Xlinker", "-rpath", "-Xlinker", libpath]                           else []                   -- Solaris 11's linker does not support -rpath-link option. It silently@@ -1744,7 +1747,7 @@          | osMachOTarget (platformOS platform) &&            dynLibLoader dflags == SystemDependent &&            WayDyn `elem` ways dflags &&-           gopt Opt_RPath dflags+           useXLinkerRPath dflags (platformOS platform)             = let libpath = if gopt Opt_RelativeDynlibPaths dflags                             then "@loader_path" </>                                  (l `makeRelativeTo` full_output_fn)@@ -2028,7 +2031,8 @@     let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []           (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)     let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []-          (includePathsQuote cmdline_include_paths)+          (includePathsQuote cmdline_include_paths +++           includePathsQuoteImplicit cmdline_include_paths)     let include_paths = include_paths_quote ++ include_paths_global      let verbFlags = getVerbFlags dflags

@@ -278,25 +278,12 @@ dsExpr (HsOverLit _ lit)   = do { warnAboutOverflowedOverLit lit        ; dsOverLit lit }-dsExpr (XExpr (ExpansionExpr (HsExpanded _ b))) = dsExpr b-dsExpr hswrap@(XExpr (WrapExpr (HsWrap co_fn e)))-  = do { e' <- case e of-                 HsVar _ (L _ var) -> return $ varToCoreExpr var-                 HsConLikeOut _ (RealDataCon dc) -> return $ varToCoreExpr (dataConWrapId dc)-                 XExpr (WrapExpr (HsWrap _ _)) -> pprPanic "dsExpr: HsWrap inside HsWrap" (ppr hswrap)-                 HsPar _ _ -> pprPanic "dsExpr: HsPar inside HsWrap" (ppr hswrap)-                 _ -> addTyCsDs FromSource (hsWrapDictBinders co_fn) $-                      dsExpr e-               -- See Note [Detecting forced eta expansion]-       ; wrap' <- dsHsWrapper co_fn-       ; dflags <- getDynFlags-       ; let wrapped_e = wrap' e'-             wrapped_ty = exprType wrapped_e-       ; checkForcedEtaExpansion e (ppr hswrap) wrapped_ty -- See Note [Detecting forced eta expansion]-         -- Pass HsWrap, so that the user can see entire expression with -fprint-typechecker-elaboration-       ; warnAboutIdentities dflags e' wrapped_ty-       ; return wrapped_e } +dsExpr e@(XExpr expansion)+  = case expansion of+      ExpansionExpr (HsExpanded _ b) -> dsExpr b+      WrapExpr {}                    -> dsHsWrapped e+ dsExpr (NegApp _ (L loc                     (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))                 neg_expr)@@ -322,9 +309,7 @@        ; dsWhenNoErrs (dsLExprNoLP arg)                       (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') } -dsExpr (HsAppType ty e _)-  = do { e' <- dsLExpr e-       ; return (App e' (Type ty)) }+dsExpr e@(HsAppType {}) = dsHsWrapped e  {- Note [Desugaring vars]@@ -905,7 +890,9 @@        ; core_res_wrap  <- dsHsWrapper res_wrap        ; let wrapped_args = zipWithEqual "dsSyntaxExpr" ($) core_arg_wraps arg_exprs        ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ])-                      (\_ -> core_res_wrap (mkApps fun wrapped_args)) }+                      (\_ -> core_res_wrap (mkCoreApps fun wrapped_args)) }+                      -- Use mkCoreApps instead of mkApps:+                      -- unboxed types are possible with RebindableSyntax (#19883)   where     mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr) dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr"@@ -1167,15 +1154,8 @@  dsHsVar :: Id -> DsM CoreExpr dsHsVar var-  | let bad_tys = badUseOfLevPolyPrimop var ty-  , not (null bad_tys)-  = do { levPolyPrimopErr (ppr var) ty bad_tys-       ; return unitExpr }  -- return something eminently safe--  | otherwise-  = return (varToCoreExpr var)   -- See Note [Desugaring vars]-  where-    ty = idType var+  = do { checkLevPolyFunction (ppr var) var (idType var)+       ; return (varToCoreExpr var) }   -- See Note [Desugaring vars]  dsConLike :: ConLike -> DsM CoreExpr dsConLike (RealDataCon dc) = dsHsVar (dataConWrapId dc)@@ -1233,36 +1213,37 @@ {- ************************************************************************ *                                                                      *-   Forced eta expansion and levity polymorphism+            Levity polymorphism checks *                                                                      * ************************************************************************ -Note [Detecting forced eta expansion]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Checking for levity-polymorphic functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We cannot have levity polymorphic function arguments. See-Note [Levity polymorphism invariants] in GHC.Core. But we *can* have-functions that take levity polymorphic arguments, as long as these-functions are eta-reduced. (See #12708 for an example.)+Note [Levity polymorphism invariants] in GHC.Core. That is+checked by dsLExprNoLP. -However, we absolutely cannot do this for functions that have no-binding (i.e., say True to Id.hasNoBinding), like primops and unboxed-tuple constructors. These get eta-expanded in CorePrep.maybeSaturate.+But what about+  const True (unsafeCoerce# :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b) -Detecting when this is about to happen is a bit tricky, though. When-the desugarer is looking at the Id itself (let's be concrete and-suppose we have (#,#)), we don't know whether it will be levity-polymorphic. So the right spot seems to be to look after the Id has-been applied to its type arguments. To make the algorithm efficient,-it's important to be able to spot ((#,#) @a @b @c @d) without looking-past all the type arguments. We thus require that-  * The body of an HsWrap is not an HsWrap, nor an HsPar.-This invariant is checked in dsExpr.-With that representation invariant, we simply look inside every HsWrap-to see if its body is an HsVar whose Id hasNoBinding. Then, we look-at the wrapped type. If it has any levity polymorphic arguments, reject.-Because we might have an HsVar without a wrapper, we check in dsHsVar-as well. typecheck/should_fail/T17021 triggers this case.+Since `unsafeCoerce#` has no binding, it has a compulsory unfolding.+But that compulsory unfolding is a levity-polymorphic lambda, which+is no good.  So we want to reject this.  On the other hand+  const True (unsafeCoerce# @LiftedRep @UnliftedRep)+is absolutely fine. +We have to collect all the type-instantiation and *then* check.  That+is what dsHsWrapped does.  Because we might have an HsVar without a+wrapper, we check in dsHsVar as well. typecheck/should_fail/T17021+triggers this case.++Note that if `f :: forall r (a :: Type r). blah`, then+   const True f+is absolutely fine.  Here `f` is a function, represented by a+pointer, and we can pass it to `const` (or anything else).  (See+#12708 for an example.)  It's only the Id.hasNoBinding functions+that are a problem.+ Interestingly, this approach does not look to see whether the Id in question will be eta expanded. The logic is this:   * Either the Id in question is saturated or not.@@ -1274,39 +1255,53 @@  -} --- | Takes an expression and its instantiated type. If the expression is an--- HsVar with a hasNoBinding primop and the type has levity-polymorphic arguments,--- issue an error. See Note [Detecting forced eta expansion]-checkForcedEtaExpansion :: HsExpr GhcTc -> SDoc -> Type -> DsM ()-checkForcedEtaExpansion expr expr_doc ty-  | Just var <- case expr of-                  HsVar _ (L _ var)               -> Just var-                  HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc)-                  _                               -> Nothing-  , let bad_tys = badUseOfLevPolyPrimop var ty-  , not (null bad_tys)-  = levPolyPrimopErr expr_doc ty bad_tys-checkForcedEtaExpansion _ _ _ = return ()---- | Is this a hasNoBinding Id with a levity-polymorphic type?--- Returns the arguments that are levity polymorphic if they are bad;--- or an empty list otherwise--- See Note [Detecting forced eta expansion]-badUseOfLevPolyPrimop :: Id -> Type -> [Type]-badUseOfLevPolyPrimop id ty-  | hasNoBinding id-  = filter isTypeLevPoly arg_tys-  | otherwise-  = []+------------------------------+dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr+-- Looks for a function 'f' wrapped in type applications (HsAppType)+-- or wrappers (HsWrap), and checks that any hasNoBinding function+-- is not levity polymorphic, *after* instantiation with those wrappers+dsHsWrapped orig_hs_expr+  = go id orig_hs_expr   where-    (binders, _) = splitPiTys ty-    arg_tys      = mapMaybe binderRelevantType_maybe binders+    go wrap (XExpr (WrapExpr (HsWrap co_fn hs_e)))+       = do { wrap' <- dsHsWrapper co_fn+            ; addTyCsDs FromSource (hsWrapDictBinders co_fn) $+              go (wrap . wrap') hs_e }+    go wrap (HsConLikeOut _ (RealDataCon dc))+      = go_head wrap (dataConWrapId dc)+    go wrap (HsAppType ty hs_e _) = go_l (wrap . (\e -> App e (Type ty))) hs_e+    go wrap (HsPar _ hs_e)        = go_l wrap hs_e+    go wrap (HsVar _ (L _ var))   = go_head wrap var+    go wrap hs_e                  = do { e <- dsExpr hs_e; return (wrap e) } -levPolyPrimopErr :: SDoc -> Type -> [Type] -> DsM ()-levPolyPrimopErr expr_doc ty bad_tys+    go_l wrap (L _ hs_e) = go wrap hs_e++    go_head wrap var+      = do { let wrapped_e  = wrap (Var var)+                 wrapped_ty = exprType wrapped_e++           ; checkLevPolyFunction (ppr orig_hs_expr) var wrapped_ty+             -- See Note [Checking for levity-polymorphic functions]+             -- Pass orig_hs_expr, so that the user can see entire+             -- expression with -fprint-typechecker-elaboration++           ; dflags <- getDynFlags+           ; warnAboutIdentities dflags var wrapped_ty++           ; return wrapped_e }+++-- | Takes a (pretty-printed) expression, a function, and its+-- instantiated type.  If the function is a hasNoBinding op, and the+-- type has levity-polymorphic arguments, issue an error.+-- Note [Checking for levity-polymorphic functions]+checkLevPolyFunction :: SDoc -> Id -> Type -> DsM ()+checkLevPolyFunction pp_hs_expr var ty+  | let bad_tys = isBadLevPolyFunction var ty+  , not (null bad_tys)   = errDs $ vcat     [ hang (text "Cannot use function with levity-polymorphic arguments:")-         2 (expr_doc <+> dcolon <+> pprWithTYPE ty)+         2 (pp_hs_expr <+> dcolon <+> pprWithTYPE ty)     , ppUnlessOption sdocPrintTypecheckerElaboration $ vcat         [ text "(Note that levity-polymorphic primops such as 'coerce' and unboxed tuples"         , text "are eta-expanded internally because they must occur fully saturated."@@ -1317,3 +1312,19 @@            (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t))            bad_tys     ]++checkLevPolyFunction _ _ _ = return ()++-- | Is this a hasNoBinding Id with a levity-polymorphic type?+-- Returns the arguments that are levity polymorphic if they are bad;+-- or an empty list otherwise+-- Note [Checking for levity-polymorphic functions]+isBadLevPolyFunction :: Id -> Type -> [Type]+isBadLevPolyFunction id ty+  | hasNoBinding id+  = filter isTypeLevPoly arg_tys+  | otherwise+  = []+  where+    (binders, _) = splitPiTys ty+    arg_tys      = mapMaybe binderRelevantType_maybe binders

@@ -145,8 +145,8 @@ same.  Then it's probably (albeit not definitely) the identity -} -warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM ()-warnAboutIdentities dflags (Var conv_fn) type_of_conv+warnAboutIdentities :: DynFlags -> Id -> Type -> DsM ()+warnAboutIdentities dflags conv_fn type_of_conv   | wopt Opt_WarnIdentities dflags   , idName conv_fn `elem` conversionNames   , Just (_, arg_ty, res_ty) <- splitFunTy_maybe type_of_conv

@@ -170,7 +170,7 @@ mkPluginUsage :: HscEnv -> ModIface -> IO [Usage] mkPluginUsage hsc_env pluginModule   = case lookupPluginModuleWithSuggestions pkgs pNm Nothing of-    LookupFound _ pkg -> do+    LookupFound _ (pkg, _) -> do     -- The plugin is from an external package:     -- search for the library files containing the plugin.       let searchPaths = collectLibraryPaths dflags [pkg]

@@ -41,6 +41,9 @@    , tcIfaceAnnotations, tcIfaceCompleteSigs )  import GHC.Driver.Session+import GHC.Driver.Hooks+import GHC.Driver.Plugins+ import GHC.Iface.Syntax import GHC.Iface.Env import GHC.Driver.Types@@ -75,11 +78,9 @@ import GHC.Utils.Misc import GHC.Data.FastString import GHC.Utils.Fingerprint-import GHC.Driver.Hooks import GHC.Types.FieldLabel import GHC.Iface.Rename import GHC.Types.Unique.DSet-import GHC.Driver.Plugins  import Control.Monad import Control.Exception@@ -591,13 +592,15 @@          -- wrinkle: when we're typechecking in --backpack mode, the          -- instantiation of a signature might reside in the HPT, so          -- this case breaks the assumption that EPS interfaces only-         -- refer to other EPS interfaces. We can detect when we're in-         -- typechecking-only mode by using hscTarget==HscNothing, and-         -- in that case we don't empty the HPT.  (admittedly this is-         -- a bit of a hack, better suggestions welcome). A number of-         -- tests in testsuite/tests/backpack break without this+         -- refer to other EPS interfaces.+         -- As a temporary (MP Oct 2021 #20509) we only keep the HPT if it+         -- contains any hole modules.+         -- Quite a few tests in testsuite/tests/backpack break without this          -- tweak.-         !hpt | hscTarget hsc_dflags == HscNothing = hsc_HPT+         keepFor20509 hmi+          | isHoleModule (mi_semantic_module (hm_iface hmi)) = True+          | otherwise = False+         !hpt | anyHpt keepFor20509 hsc_HPT  = hsc_HPT               | otherwise = emptyHomePackageTable        in        HscEnv {  hsc_targets      = panic "cleanTopEnv: hsc_targets"

@@ -44,8 +44,12 @@         lang = (fmap fromEnum language,                 map fromEnum $ EnumSet.toList extensionFlags) +        -- avoid fingerprinting the absolute path to the directory of the source file+        -- see note [Implicit include paths]+        includePathsMinusImplicit = includePaths { includePathsQuoteImplicit = [] }+         -- -I, -D and -U flags affect CPP-        cpp = ( map normalise $ flattenIncludes includePaths+        cpp = ( map normalise $ flattenIncludes includePathsMinusImplicit             -- normalise: eliminate spurious differences due to "./foo" vs "foo"               , picPOpts dflags               , opt_P_signature dflags)

@@ -1,157 +0,0 @@-{-# LANGUAGE CPP, BangPatterns, Strict, RecordWildCards #-}--module GHC.Iface.UpdateIdInfos-  ( updateModDetailsIdInfos-  ) where--import GHC.Prelude--import GHC.Core-import GHC.Core.InstEnv-import GHC.Driver.Session-import GHC.Driver.Types-import GHC.StgToCmm.Types (CgInfos (..))-import GHC.Types.Id-import GHC.Types.Id.Info-import GHC.Types.Name.Env-import GHC.Types.Name.Set-import GHC.Types.Var-import GHC.Utils.Misc-import GHC.Utils.Outputable--#include "GhclibHsVersions.h"---- | Update CafInfos and LFInfos of all occurences (in rules, unfoldings, class--- instances).------ See Note [Conveying CAF-info and LFInfo between modules] in--- GHC.StgToCmm.Types.-updateModDetailsIdInfos-  :: DynFlags-  -> CgInfos-  -> ModDetails -- ^ ModDetails to update-  -> ModDetails--updateModDetailsIdInfos dflags _ mod_details-  | gopt Opt_OmitInterfacePragmas dflags-  = mod_details--updateModDetailsIdInfos _ cg_infos mod_details =-  let-    ModDetails{ md_types = type_env -- for unfoldings-              , md_insts = insts-              , md_rules = rules-              } = mod_details--    -- type TypeEnv = NameEnv TyThing-    ~type_env' = mapNameEnv (updateTyThingIdInfos type_env' cg_infos) type_env-    -- Not strict!--    !insts' = strictMap (updateInstIdInfos type_env' cg_infos) insts-    !rules' = strictMap (updateRuleIdInfos type_env') rules-  in-    mod_details{ md_types = type_env'-               , md_insts = insts'-               , md_rules = rules'-               }------------------------------------------------------------------------------------- Rules-----------------------------------------------------------------------------------updateRuleIdInfos :: TypeEnv -> CoreRule -> CoreRule-updateRuleIdInfos _ rule@BuiltinRule{} = rule-updateRuleIdInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_env ru_rhs, .. }------------------------------------------------------------------------------------- Instances-----------------------------------------------------------------------------------updateInstIdInfos :: TypeEnv -> CgInfos -> ClsInst -> ClsInst-updateInstIdInfos type_env cg_infos =-    updateClsInstDFun (updateIdUnfolding type_env . updateIdInfo cg_infos)------------------------------------------------------------------------------------- TyThings-----------------------------------------------------------------------------------updateTyThingIdInfos :: TypeEnv -> CgInfos -> TyThing -> TyThing--updateTyThingIdInfos type_env cg_infos (AnId id) =-    AnId (updateIdUnfolding type_env (updateIdInfo cg_infos id))--updateTyThingIdInfos _ _ other = other -- AConLike, ATyCon, ACoAxiom------------------------------------------------------------------------------------- Unfoldings-----------------------------------------------------------------------------------updateIdUnfolding :: TypeEnv -> Id -> Id-updateIdUnfolding type_env id =-    case idUnfolding id of-      CoreUnfolding{ .. } ->-        setIdUnfolding id CoreUnfolding{ uf_tmpl = updateGlobalIds type_env uf_tmpl, .. }-      DFunUnfolding{ .. } ->-        setIdUnfolding id DFunUnfolding{ df_args = map (updateGlobalIds type_env) df_args, .. }-      _ -> id------------------------------------------------------------------------------------- Expressions-----------------------------------------------------------------------------------updateIdInfo :: CgInfos -> Id -> Id-updateIdInfo CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf_infos } id =-    let-      not_caffy = elemNameSet (idName id) non_cafs-      mb_lf_info = lookupNameEnv lf_infos (idName id)--      id1 = if not_caffy then setIdCafInfo id NoCafRefs else id-      id2 = case mb_lf_info of-              Nothing -> id1-              Just lf_info -> setIdLFInfo id1 lf_info-    in-      id2------------------------------------------------------------------------------------updateGlobalIds :: NameEnv TyThing -> CoreExpr -> CoreExpr--- Update occurrences of GlobalIds as directed by 'env'--- The 'env' maps a GlobalId to a version with accurate CAF info--- (and in due course perhaps other back-end-related info)-updateGlobalIds env e = go env e-  where-    go_id :: NameEnv TyThing -> Id -> Id-    go_id env var =-      case lookupNameEnv env (varName var) of-        Nothing -> var-        Just (AnId id) -> id-        Just other -> pprPanic "UpdateIdInfos.updateGlobalIds" $-          text "Found a non-Id for Id Name" <+> ppr (varName var) $$-          nest 4 (text "Id:" <+> ppr var $$-                  text "TyThing:" <+> ppr other)--    go :: NameEnv TyThing -> CoreExpr -> CoreExpr-    go env (Var v) = Var (go_id env v)-    go _ e@Lit{} = e-    go env (App e1 e2) = App (go env e1) (go env e2)-    go env (Lam b e) = assertNotInNameEnv env [b] (Lam b (go env e))-    go env (Let bs e) = Let (go_binds env bs) (go env e)-    go env (Case e b ty alts) =-        assertNotInNameEnv env [b] (Case (go env e) b ty (map go_alt alts))-      where-         go_alt (k,bs,e) = assertNotInNameEnv env bs (k, bs, go env e)-    go env (Cast e c) = Cast (go env e) c-    go env (Tick t e) = Tick t (go env e)-    go _ e@Type{} = e-    go _ e@Coercion{} = e--    go_binds :: NameEnv TyThing -> CoreBind -> CoreBind-    go_binds env (NonRec b e) =-      assertNotInNameEnv env [b] (NonRec b (go env e))-    go_binds env (Rec prs) =-      assertNotInNameEnv env (map fst prs) (Rec (mapSnd (go env) prs))---- In `updateGlobaLIds` Names of local binders should not shadow Name of--- globals. This assertion is to check that.-assertNotInNameEnv :: NameEnv a -> [Id] -> b -> b-assertNotInNameEnv env ids x = ASSERT(not (any (\id -> elemNameEnv (idName id) env) ids)) x

@@ -606,7 +606,7 @@   -- `checkPatSynParent`.   traceRn "parent" (ppr parent)   traceRn "lookupExportChild original_gres:" (ppr original_gres)-  traceRn "lookupExportChild picked_gres:" (ppr $ picked_gres original_gres)+  traceRn "lookupExportChild picked_gres:" (ppr (picked_gres original_gres) $$ ppr must_have_parent)   case picked_gres original_gres of     NoOccurrence ->       noMatchingParentErr original_gres@@ -647,6 +647,7 @@         --     constructors, neither of which is the parent.         noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult         noMatchingParentErr original_gres = do+          traceRn "npe" (ppr original_gres)           overload_ok <- xoptM LangExt.DuplicateRecordFields           case original_gres of             [] ->  return NameNotFound

@@ -200,7 +200,10 @@               _ -> return (Fixity NoSourceText minPrecedence InfixL)                    -- c.f. lookupFixity for unbound -        ; final_e <- mkOpAppRn e1' op' fixity e2'+        ; lexical_negation <- xoptM LangExt.LexicalNegation+        ; let negation_handling | lexical_negation = KeepNegationIntact+                                | otherwise = ReassociateNegation+        ; final_e <- mkOpAppRn negation_handling e1' op' fixity e2'         ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }  rnExpr (NegApp _ e _)

@@ -21,6 +21,7 @@         rnScaledLHsType,          -- Precence related stuff+        NegationHandling(..),         mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,         checkPrecMatch, checkSectionPrec, @@ -1228,20 +1229,21 @@   ----------------------------mkOpAppRn :: LHsExpr GhcRn             -- Left operand; already rearranged+mkOpAppRn :: NegationHandling+          -> LHsExpr GhcRn             -- Left operand; already rearranged           -> LHsExpr GhcRn -> Fixity   -- Operator and fixity           -> LHsExpr GhcRn             -- Right operand (not an OpApp, but might                                        -- be a NegApp)           -> RnM (HsExpr GhcRn)  -- (e11 `op1` e12) `op2` e2-mkOpAppRn e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2+mkOpAppRn negation_handling e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2   | nofix_error   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)        return (OpApp fix2 e1 op2 e2)    | associate_right = do-    new_e <- mkOpAppRn e12 op2 fix2 e2+    new_e <- mkOpAppRn negation_handling e12 op2 fix2 e2     return (OpApp fix1 e11 op1 (L loc' new_e))   where     loc'= combineLocs e12 e2@@ -1249,13 +1251,13 @@  --------------------------- --      (- neg_arg) `op` e2-mkOpAppRn e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2+mkOpAppRn ReassociateNegation e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2   | nofix_error   = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2)        return (OpApp fix2 e1 op2 e2)    | associate_right-  = do new_e <- mkOpAppRn neg_arg op2 fix2 e2+  = do new_e <- mkOpAppRn ReassociateNegation neg_arg op2 fix2 e2        return (NegApp noExtField (L loc' new_e) neg_name)   where     loc' = combineLocs neg_arg e2@@ -1263,7 +1265,7 @@  --------------------------- --      e1 `op` - neg_arg-mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right+mkOpAppRn ReassociateNegation e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right   | not associate_right                        -- We *want* right association   = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity)        return (OpApp fix1 e1 op1 e2)@@ -1272,11 +1274,11 @@  --------------------------- --      Default case-mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment-  = ASSERT2( right_op_ok fix (unLoc e2),-             ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2-    )+mkOpAppRn _ e1 op fix e2                  -- Default case, no rearrangment+  = ASSERT2(right_op_ok fix (unLoc e2), ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2)     return (OpApp fix e1 op e2)++data NegationHandling = ReassociateNegation | KeepNegationIntact  ---------------------------- 

@@ -705,9 +705,12 @@         ; traceRn "getLocalNonValBinders 2" (ppr avails)         ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env +        -- Force the field access so that tcg_env is not retained. The+        -- selector thunk optimisation doesn't kick-in, see #20139+        ; let !old_field_env = tcg_field_env tcg_env         -- Extend tcg_field_env with new fields (this used to be the         -- work of extendRecordFieldEnv)-        ; let field_env = extendNameEnvList (tcg_field_env tcg_env) flds+              field_env = extendNameEnvList old_field_env flds               envs      = (tcg_env { tcg_field_env = field_env }, tcl_env)          ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env])

@@ -928,7 +928,7 @@                            concatMap (\l -> [ Option ("-l" ++ l) ])                                      (nub $ snd <$> temp_sos)                         ++ concatMap (\lp -> Option ("-L" ++ lp)-                                          : if gopt Opt_RPath dflags+                                          : if useXLinkerRPath dflags (platformOS platform)                                             then [ Option "-Xlinker"                                                  , Option "-rpath"                                                  , Option "-Xlinker"@@ -937,7 +937,7 @@                                      (nub $ fst <$> temp_sos)                         ++ concatMap                              (\lp -> Option ("-L" ++ lp)-                                  : if gopt Opt_RPath dflags+                                  : if useXLinkerRPath dflags (platformOS platform)                                     then [ Option "-Xlinker"                                          , Option "-rpath"                                          , Option "-Xlinker"

@@ -102,9 +102,9 @@  For example, say we have (# (# Int#, Char #) | (# Int#, Int# #) | Int# #) -  - Layouts of alternatives: [ [Word, Ptr], [Word, Word], [Word] ]-  - Sorted: [ [Ptr, Word], [Word, Word], [Word] ]-  - Merge all alternatives together: [ Ptr, Word, Word ]+  - Layouts of alternatives: [ [Word, LiftedPtr], [Word, Word], [Word] ]+  - Sorted: [ [LiftedPtr, Word], [Word, Word], [Word] ]+  - Merge all alternatives together: [ LiftedPtr, Word, Word ]  We add a slot for the tag to the first position. So our tuple type is @@ -126,6 +126,44 @@    (# 2#, rubbish, 2#, 3# #). ++Note [Don't merge lifted and unlifted slots]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When merging slots, one might be tempted to collapse lifted and unlifted+pointers. However, as seen in #19645, this is wrong. Imagine that you have+the program:++  test :: (# Char | ByteArray# #) -> ByteArray#+  test (# c | #) = doSomething c+  test (# | ba #) = ba++Collapsing the Char and ByteArray# slots would produce STG like:++  test :: forall {t}. (# t | GHC.Prim.ByteArray# #) -> GHC.Prim.ByteArray#+    = {} \r [ (tag :: Int#) (slot0 :: (Any :: Type)) ]+          case tag of tag'+            1# -> doSomething slot0+            2# -> slot0;++Note how `slot0` has a lifted type, despite being bound to an unlifted+ByteArray# in the 2# alternative. This liftedness would cause the code generator to+attempt to enter it upon returning. As unlifted objects do not have entry code,+this causes a runtime crash.++For this reason, Unarise treats unlifted and lifted things as distinct slot+types, despite both being GC pointers. This approach is a slight pessimisation+(since we need to pass more arguments) but appears to be the simplest way to+avoid #19645. Other alternatives considered include:++ a. Giving unlifted objects "trivial" entry code. However, we ultimately+    concluded that the value of the "unlifted things are never entered" invariant+    outweighed the simplicity of this approach.++ b. Annotating occurrences with calling convention information instead of+    relying on the binder's type. This seemed like a very complicated+    way to fix what is ultimately a corner-case.++ Note [Types in StgConApp] ~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have this unboxed sum term:@@ -593,7 +631,8 @@ -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in "GHC.Core.Make" -- ubxSumRubbishArg :: SlotTy -> StgArg-ubxSumRubbishArg PtrSlot    = StgVarArg aBSENT_SUM_FIELD_ERROR_ID+ubxSumRubbishArg PtrLiftedSlot    = StgVarArg aBSENT_SUM_FIELD_ERROR_ID+ubxSumRubbishArg PtrUnliftedSlot  = StgVarArg aBSENT_SUM_FIELD_ERROR_ID ubxSumRubbishArg WordSlot   = StgLitArg (LitNumber LitNumWord 0) ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0) ubxSumRubbishArg FloatSlot  = StgLitArg (LitFloat 0)

@@ -1521,6 +1521,7 @@   TraceMarkerOp -> alwaysExternal   SetThreadAllocationCounter -> alwaysExternal +  -- See Note [keepAlive# magic] in GHC.CoreToStg.Prep.   KeepAliveOp -> panic "keepAlive# should have been eliminated in CorePrep"   where@@ -2643,7 +2644,7 @@         dst_off <- assignTempE dst_off0          -- Nonmoving collector write barrier-        emitCopyUpdRemSetPush platform (arrPtrsHdrSizeW dflags) dst dst_off n+        emitCopyUpdRemSetPush platform (arrPtrsHdrSize dflags) dst dst_off n          -- Set the dirty bit in the header.         emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))@@ -2709,7 +2710,7 @@         dst     <- assignTempE dst0          -- Nonmoving collector write barrier-        emitCopyUpdRemSetPush platform (smallArrPtrsHdrSizeW dflags) dst dst_off n+        emitCopyUpdRemSetPush platform (smallArrPtrsHdrSize dflags) dst dst_off n          -- Set the dirty bit in the header.         emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))@@ -3042,7 +3043,7 @@ -- | Push a range of pointer-array elements that are about to be copied over to -- the update remembered set. emitCopyUpdRemSetPush :: Platform-                      -> WordOff    -- ^ array header size+                      -> ByteOff    -- ^ array header size (in bytes)                       -> CmmExpr    -- ^ destination array                       -> CmmExpr    -- ^ offset in destination array (in words)                       -> Int        -- ^ number of elements to copy

@@ -252,7 +252,7 @@                 -- C compiler (that compiles the RTS, in particular) does                 -- layouts of structs containing long-longs, simply                 -- pad out the struct with zero words until we hit the-                -- size of the overall struct (which we get via DerivedConstants.h)+                -- size of the overall struct (which we get via GhclibDerivedConstants.h)            emitDataLits (mkCCSLabel ccs) (mk_lits cc)     Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs) 

@@ -248,6 +248,8 @@      pkgs <- getPreloadUnitsAnd dflags dep_packages +    let platform = targetPlatform dflags+        os = platformOS platform     let pkg_lib_paths = collectLibraryPaths dflags pkgs     let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths         get_pkg_lib_path_opts l@@ -257,7 +259,7 @@            -- Only if we want dynamic libraries            WayDyn `Set.member` ways dflags &&            -- Only use RPath if we explicitly asked for it-           gopt Opt_RPath dflags+           useXLinkerRPath dflags os             = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l]               -- See Note [-Xlinker -rpath vs -Wl,-rpath]          | otherwise = ["-L" ++ l]@@ -272,9 +274,7 @@     -- not allow undefined symbols.     -- The RTS library path is still added to the library search path     -- above in case the RTS is being explicitly linked in (see #3807).-    let platform = targetPlatform dflags-        os = platformOS platform-        pkgs_no_rts = case os of+    let pkgs_no_rts = case os of                       OSMinGW32 ->                           pkgs                       _ | gopt Opt_LinkRts dflags ->@@ -372,7 +372,7 @@                  ++ [ Option "-undefined",                       Option "dynamic_lookup",                       Option "-single_module" ]-                 ++ (if platformArch platform == ArchX86_64+                 ++ (if platformArch platform `elem` [ ArchX86_64, ArchAArch64 ]                      then [ ]                      else [ Option "-Wl,-read_only_relocs,suppress" ])                  ++ [ Option "-install_name", Option instName ]

@@ -11,6 +11,7 @@  import GHC.Utils.Exception as Exception import GHC.Utils.Error+import GHC.CmmToLlvm.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound, llvmVersionStr, parseLlvmVersion) import GHC.Driver.Types import GHC.Driver.Session import GHC.Utils.Outputable@@ -18,19 +19,20 @@ import GHC.Utils.Misc  import Data.List+import Data.Char+import Data.Maybe  import System.IO import System.Process import GHC.Prelude -import GHC.CmmToLlvm.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersion, parseLlvmVersion)- import GHC.SysTools.Process import GHC.SysTools.Info -import Control.Monad (join, forM, filterM)+import Control.Monad (join, forM, filterM, void) import System.Directory (doesFileExist) import System.FilePath ((</>))+import Text.ParserCombinators.ReadP as Parser  {- ************************************************************************@@ -213,7 +215,7 @@       -- options are specified when '-version' is used.       args' = args ++ ["-version"]   catchIO (do-              (pin, pout, perr, _) <- runInteractiveProcess pgm args'+              (pin, pout, perr, p) <- runInteractiveProcess pgm args'                                               Nothing Nothing               {- > llc -version                   LLVM (http://llvm.org/):@@ -227,6 +229,7 @@               hClose pin               hClose pout               hClose perr+              _ <- waitForProcess p               return mb_ver             )             (\err -> do@@ -236,8 +239,11 @@                 errorMsg dflags $ vcat                     [ text "Warning:", nest 9 $                           text "Couldn't figure out LLVM version!" $$-                          text ("Make sure you have installed LLVM " ++-                                llvmVersionStr supportedLlvmVersion) ]+                          text ("Make sure you have installed LLVM between ["+                                ++ llvmVersionStr supportedLlvmVersionLowerBound+                                ++ " and "+                                ++ llvmVersionStr supportedLlvmVersionUpperBound+                                ++ ")") ]                 return Nothing)  @@ -258,15 +264,15 @@ -- -- See Note [Dynamic linking on macOS] runInjectRPaths :: DynFlags -> [FilePath] -> FilePath -> IO ()+runInjectRPaths dflags _ _ | not (gopt Opt_RPath dflags) = return () runInjectRPaths dflags lib_paths dylib = do   info <- lines <$> askOtool dflags Nothing [Option "-L", Option dylib]   -- filter the output for only the libraries. And then drop the @rpath prefix.   let libs = fmap (drop 7) $ filter (isPrefixOf "@rpath") $ fmap (head.words) $ info   -- find any pre-existing LC_PATH items-  info <- fmap words.lines <$> askOtool dflags Nothing [Option "-l", Option dylib]-  let paths = concatMap f info-        where f ("path":p:_) = [p]-              f _            = []+  info <- lines <$> askOtool dflags Nothing [Option "-l", Option dylib]++  let paths = mapMaybe get_rpath info       lib_paths' = [ p | p <- lib_paths, not (p `elem` paths) ]   -- only find those rpaths, that aren't already in the library.   rpaths <- nub.sort.join <$> forM libs (\f -> filterM (\l -> doesFileExist (l </> f)) lib_paths')@@ -275,6 +281,24 @@     [] -> return ()     _  -> runInstallNameTool dflags $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib] +get_rpath :: String -> Maybe FilePath+get_rpath l = case readP_to_S rpath_parser l of+                [(rpath, "")] -> Just rpath+                _ -> Nothing+++rpath_parser :: ReadP FilePath+rpath_parser = do+  skipSpaces+  void $ string "path"+  void $ many1 (satisfy isSpace)+  rpath <- many get+  void $ many1 (satisfy isSpace)+  void $ string "(offset "+  void $ munch1 isDigit+  void $ Parser.char ')'+  skipSpaces+  return rpath  runLink :: DynFlags -> [Option] -> IO () runLink dflags args = traceToolCommand dflags "linker" $ do

@@ -54,6 +54,7 @@ import GHC.Data.Bag import GHC.Utils.Error  ( ErrMsg, errDoc, pprLocErrMsg ) import GHC.Types.Basic+import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) import GHC.Core.ConLike ( ConLike(..)) import GHC.Utils.Misc import GHC.Data.FastString@@ -65,7 +66,7 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.FV ( fvVarList, unionFV ) -import Control.Monad    ( when )+import Control.Monad    ( when, unless ) import Data.Foldable    ( toList ) import Data.List        ( partition, mapAccumL, nub, sortBy, unfoldr ) @@ -723,10 +724,35 @@ reportHoles :: [Ct]  -- other (tidied) constraints             -> ReportErrCtxt -> [Hole] -> TcM () reportHoles tidy_cts ctxt-  = mapM_ $ \hole -> do { err <- mkHoleError tidy_cts ctxt hole+  = mapM_ $ \hole -> unless (ignoreThisHole ctxt hole) $+                     do { err <- mkHoleError tidy_cts ctxt hole                         ; maybeReportHoleError ctxt hole err                         ; maybeAddDeferredHoleBinding ctxt err hole } +ignoreThisHole :: ReportErrCtxt -> Hole -> Bool+-- See Note [Skip type holes rapidly]+ignoreThisHole ctxt hole+  = case hole_sort hole of+       ExprHole {}    -> False+       TypeHole       -> ignore_type_hole+  where+    ignore_type_hole = case cec_type_holes ctxt of+                         HoleDefer -> True+                         _         -> False++{- Note [Skip type holes rapidly]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have module with a /lot/ of partial type signatures, and we+compile it while suppressing partial-type-signature warnings.  Then+we don't want to spend ages constructing error messages and lists of+relevant bindings that we never display! This happened in #14766, in+which partial type signatures in a Happy-generated parser cause a huge+increase in compile time.++The function ignoreThisHole short-circuits the error/warning generation+machinery, in cases where it is definitely going to be a no-op.+-}+ mkUserTypeErrorReporter :: Reporter mkUserTypeErrorReporter ctxt   = mapM_ $ \ct -> do { err <- mkUserTypeError ctxt ct@@ -2276,6 +2302,17 @@     -- but we really only want to report the latter     elim_superclasses cts = mkMinimalBySCs ctPred cts +-- [Note: mk_dict_err]+-- ~~~~~~~~~~~~~~~~~~~+-- Different dictionary error messages are reported depending on the number of+-- matches and unifiers:+--+--   - No matches, regardless of unifiers: report "No instance for ...".+--   - Two or more matches, regardless of unifiers: report "Overlapping instances for ...",+--     and show the matching and unifying instances.+--   - One match, one or more unifiers: report "Overlapping instances for", show the+--     matching and unifying instances, and say "The choice depends on the instantion of ...,+--     and the result of evaluating ...". mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)             -> TcM (ReportErrCtxt, SDoc) -- Report an overlap error if this class constraint results@@ -2441,12 +2478,24 @@                       , nest 2 (vcat (pp_givens useful_givens))]               ,  ppWhen (isSingleton matches) $-                parens (vcat [ text "The choice depends on the instantiation of" <+>-                                  quotes (pprWithCommas ppr (tyCoVarsOfTypesList tys))+                parens (vcat [ ppUnless (null tyCoVars) $+                                 text "The choice depends on the instantiation of" <+>+                                   quotes (pprWithCommas ppr tyCoVars)+                             , ppUnless (null famTyCons) $+                                 if (null tyCoVars)+                                   then+                                     text "The choice depends on the result of evaluating" <+>+                                       quotes (pprWithCommas ppr famTyCons)+                                   else+                                     text "and the result of evaluating" <+>+                                       quotes (pprWithCommas ppr famTyCons)                              , ppWhen (null (matching_givens)) $                                vcat [ text "To pick the first instance above, use IncoherentInstances"                                     , text "when compiling the other instance declarations"]                         ])]+      where+        tyCoVars = tyCoVarsOfTypesList tys+        famTyCons = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys      matching_givens = mapMaybe matchable useful_givens 

@@ -3,7 +3,25 @@ {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Tc.Errors.Hole    ( findValidHoleFits+   , tcCheckHoleFit+   , withoutUnification+   , tcSubsumes+   , isFlexiTyVar+   , tcFilterHoleFits+   , getLocalBindings+   , pprHoleFit+   , addHoleFitDocs+   , getHoleFitSortingAlg+   , getHoleFitDispConfig+   , HoleFitDispConfig (..)+   , HoleFitSortingAlg (..)+   , relevantCts+   , zonkSubs +   , sortHoleFitsByGraph+   , sortHoleFitsBySize++    -- Re-exported from GHC.Tc.Errors.Hole.FitTypes    , HoleFitPlugin (..), HoleFitPluginR (..)    )@@ -389,37 +407,37 @@                     , showMatches = sMatc } }  -- Which sorting algorithm to use-data SortingAlg = NoSorting      -- Do not sort the fits at all-                | BySize         -- Sort them by the size of the match-                | BySubsumption  -- Sort by full subsumption+data HoleFitSortingAlg = HFSNoSorting      -- Do not sort the fits at all+                       | HFSBySize         -- Sort them by the size of the match+                       | HFSBySubsumption  -- Sort by full subsumption                 deriving (Eq, Ord) -getSortingAlg :: TcM SortingAlg-getSortingAlg =+getHoleFitSortingAlg :: TcM HoleFitSortingAlg+getHoleFitSortingAlg =     do { shouldSort <- goptM Opt_SortValidHoleFits        ; subsumSort <- goptM Opt_SortBySubsumHoleFits        ; sizeSort <- goptM Opt_SortBySizeHoleFits        -- We default to sizeSort unless it has been explicitly turned off        -- or subsumption sorting has been turned on.        ; return $ if not shouldSort-                    then NoSorting+                    then HFSNoSorting                     else if subsumSort-                         then BySubsumption+                         then HFSBySubsumption                          else if sizeSort-                              then BySize-                              else NoSorting }+                              then HFSBySize+                              else HFSNoSorting }  -- If enabled, we go through the fits and add any associated documentation, -- by looking it up in the module or the environment (for local fits)-addDocs :: [HoleFit] -> TcM [HoleFit]-addDocs fits =+addHoleFitDocs :: [HoleFit] -> TcM [HoleFit]+addHoleFitDocs fits =   do { showDocs <- goptM Opt_ShowDocsOfHoleFits      ; if showDocs        then do { (_, DeclDocMap lclDocs, _) <- extractDocs <$> getGblEnv                ; mapM (upd lclDocs) fits }        else return fits }   where-   msg = text "GHC.Tc.Errors.Hole addDocs"+   msg = text "GHC.Tc.Errors.Hole addHoleFitDocs"    lookupInIface name (ModIface { mi_decl_docs = DeclDocMap dmap })      = Map.lookup name dmap    upd lclDocs fit@(HoleFit {hfCand = cand}) =@@ -523,12 +541,13 @@      ; lclBinds <- getLocalBindings tidy_env ct_loc      ; maxVSubs <- maxValidHoleFits <$> getDynFlags      ; hfdc <- getHoleFitDispConfig-     ; sortingAlg <- getSortingAlg+     ; sortingAlg <- getHoleFitSortingAlg      ; dflags <- getDynFlags      ; hfPlugs <- tcg_hf_plugins <$> getGblEnv-     ; let findVLimit = if sortingAlg > NoSorting then Nothing else maxVSubs+     ; let findVLimit = if sortingAlg > HFSNoSorting then Nothing else maxVSubs            refLevel = refLevelHoleFits dflags-           hole = TypedHole { th_relevant_cts = listToBag relevantCts+           hole = TypedHole { th_relevant_cts =+                                listToBag (relevantCts hole_ty simples)                             , th_implics      = implics                             , th_hole         = Just h }            (candidatePlugins, fitPlugins) =@@ -556,7 +575,7 @@      ; plugin_handled_subs <- foldM (flip ($)) tidy_sorted_subs fitPlugins      ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs plugin_handled_subs            vDiscards = pVDisc || searchDiscards-     ; subs_with_docs <- addDocs limited_subs+     ; subs_with_docs <- addHoleFitDocs limited_subs      ; let vMsg = ppUnless (null subs_with_docs) $                     hang (text "Valid hole fits include") 2 $                       vcat (map (pprHoleFit hfdc) subs_with_docs)@@ -571,8 +590,8 @@             -- to allow.             ; ref_tys <- mapM mkRefTy refLvls             ; traceTc "ref_tys are" $ ppr ref_tys-            ; let findRLimit = if sortingAlg > NoSorting then Nothing-                                                         else maxRSubs+            ; let findRLimit = if sortingAlg > HFSNoSorting then Nothing+                                                            else maxRSubs             ; refDs <- mapM (flip (tcFilterHoleFits findRLimit hole)                               cands) ref_tys             ; (tidy_env, tidy_rsubs) <- zonkSubs tidy_env $ concatMap snd refDs@@ -589,7 +608,7 @@             ; let (pRDisc, exact_last_rfits) =                     possiblyDiscard maxRSubs $ plugin_handled_rsubs                   rDiscards = pRDisc || any fst refDs-            ; rsubs_with_docs <- addDocs exact_last_rfits+            ; rsubs_with_docs <- addHoleFitDocs exact_last_rfits             ; return (tidy_env,                 ppUnless (null rsubs_with_docs) $                   hang (text "Valid refinement hole fits include") 2 $@@ -599,10 +618,7 @@      ; traceTc "findingValidHoleFitsFor }" empty      ; return (tidy_env, vMsg $$ refMsg) }   where-    -- We extract the type, the tcLevel and the types free variables-    -- from the constraint.-    hole_fvs :: FV-    hole_fvs = tyCoFVsOfType hole_ty+    -- We extract the TcLevel from the constraint.     hole_lvl = ctLocLevel ct_loc      -- BuiltInSyntax names like (:) and []@@ -622,58 +638,37 @@             setLvl = flip setMetaTyVarTcLevel hole_lvl             wrapWithVars vars = mkVisFunTysMany (map mkTyVarTy vars) hole_ty -    sortFits :: SortingAlg    -- How we should sort the hole fits+    sortFits :: HoleFitSortingAlg    -- How we should sort the hole fits              -> [HoleFit]     -- The subs to sort              -> TcM [HoleFit]-    sortFits NoSorting subs = return subs-    sortFits BySize subs-        = (++) <$> sortBySize (sort lclFits)-               <*> sortBySize (sort gblFits)+    sortFits HFSNoSorting subs = return subs+    sortFits HFSBySize subs+        = (++) <$> sortHoleFitsBySize (sort lclFits)+               <*> sortHoleFitsBySize (sort gblFits)         where (lclFits, gblFits) = span hfIsLcl subs-     -- To sort by subsumption, we invoke the sortByGraph function, which     -- builds the subsumption graph for the fits and then sorts them using a     -- graph sort.  Since we want locals to come first anyway, we can sort     -- them separately. The substitutions are already checked in local then     -- global order, so we can get away with using span here.     -- We use (<*>) to expose the parallelism, in case it becomes useful later.-    sortFits BySubsumption subs-        = (++) <$> sortByGraph (sort lclFits)-               <*> sortByGraph (sort gblFits)+    sortFits HFSBySubsumption subs+        = (++) <$> sortHoleFitsByGraph (sort lclFits)+               <*> sortHoleFitsByGraph (sort gblFits)         where (lclFits, gblFits) = span hfIsLcl subs -    -- See Note [Relevant constraints]-    relevantCts :: [Ct]-    relevantCts = if isEmptyVarSet (fvVarSet hole_fvs) then []-                  else filter isRelevant simples-      where ctFreeVarSet :: Ct -> VarSet-            ctFreeVarSet = fvVarSet . tyCoFVsOfType . ctPred-            hole_fv_set = fvVarSet hole_fvs-            anyFVMentioned :: Ct -> Bool-            anyFVMentioned ct = ctFreeVarSet ct `intersectsVarSet` hole_fv_set-            -- We filter out those constraints that have no variables (since-            -- they won't be solved by finding a type for the type variable-            -- representing the hole) and also other holes, since we're not-            -- trying to find hole fits for many holes at once.-            isRelevant ct = not (isEmptyVarSet (ctFreeVarSet ct))-                            && anyFVMentioned ct+    subsDiscardMsg :: SDoc+    subsDiscardMsg =+        text "(Some hole fits suppressed;" <+>+        text "use -fmax-valid-hole-fits=N" <+>+        text "or -fno-max-valid-hole-fits)" -    -- We zonk the hole fits so that the output aligns with the rest-    -- of the typed hole error message output.-    zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit])-    zonkSubs = zonkSubs' []-      where zonkSubs' zs env [] = return (env, reverse zs)-            zonkSubs' zs env (hf:hfs) = do { (env', z) <- zonkSub env hf-                                           ; zonkSubs' (z:zs) env' hfs }+    refSubsDiscardMsg :: SDoc+    refSubsDiscardMsg =+        text "(Some refinement hole fits suppressed;" <+>+        text "use -fmax-refinement-hole-fits=N" <+>+        text "or -fno-max-refinement-hole-fits)" -            zonkSub :: TidyEnv -> HoleFit -> TcM (TidyEnv, HoleFit)-            zonkSub env hf@RawHoleFit{} = return (env, hf)-            zonkSub env hf@HoleFit{hfType = ty, hfMatches = m, hfWrap = wrp}-              = do { (env, ty') <- zonkTidyTcType env ty-                   ; (env, m') <- zonkTidyTcTypes env m-                   ; (env, wrp') <- zonkTidyTcTypes env wrp-                   ; let zFit = hf {hfType = ty', hfMatches = m', hfWrap = wrp'}-                   ; return (env, zFit ) }      -- Based on the flags, we might possibly discard some or all the     -- fits we've found.@@ -681,42 +676,74 @@     possiblyDiscard (Just max) fits = (fits `lengthExceeds` max, take max fits)     possiblyDiscard Nothing fits = (False, fits) -    -- Sort by size uses as a measure for relevance the sizes of the-    -- different types needed to instantiate the fit to the type of the hole.-    -- This is much quicker than sorting by subsumption, and gives reasonable-    -- results in most cases.-    sortBySize :: [HoleFit] -> TcM [HoleFit]-    sortBySize = return . sortOn sizeOfFit-      where sizeOfFit :: HoleFit -> TypeSize-            sizeOfFit = sizeTypes . nubBy tcEqType .  hfWrap -    -- Based on a suggestion by phadej on #ghc, we can sort the found fits-    -- by constructing a subsumption graph, and then do a topological sort of-    -- the graph. This makes the most specific types appear first, which are-    -- probably those most relevant. This takes a lot of work (but results in-    -- much more useful output), and can be disabled by-    -- '-fno-sort-valid-hole-fits'.-    sortByGraph :: [HoleFit] -> TcM [HoleFit]-    sortByGraph fits = go [] fits-      where tcSubsumesWCloning :: TcType -> TcType -> TcM Bool-            tcSubsumesWCloning ht ty = withoutUnification fvs (tcSubsumes ht ty)-              where fvs = tyCoFVsOfTypes [ht,ty]-            go :: [(HoleFit, [HoleFit])] -> [HoleFit] -> TcM [HoleFit]-            go sofar [] = do { traceTc "subsumptionGraph was" $ ppr sofar-                             ; return $ uncurry (++)-                                         $ partition hfIsLcl topSorted }-              where toV (hf, adjs) = (hf, hfId hf, map hfId adjs)-                    (graph, fromV, _) = graphFromEdges $ map toV sofar-                    topSorted = map ((\(h,_,_) -> h) . fromV) $ topSort graph-            go sofar (hf:hfs) =-              do { adjs <--                     filterM (tcSubsumesWCloning (hfType hf) . hfType) fits-                 ; go ((hf, adjs):sofar) hfs }- -- We don't (as of yet) handle holes in types, only in expressions. findValidHoleFits env _ _ _ = return (env, empty) +-- See Note [Relevant constraints]+relevantCts :: Type -> [Ct] -> [Ct]+relevantCts hole_ty simples = if isEmptyVarSet (fvVarSet hole_fvs) then []+                              else filter isRelevant simples+  where ctFreeVarSet :: Ct -> VarSet+        ctFreeVarSet = fvVarSet . tyCoFVsOfType . ctPred+        hole_fvs = tyCoFVsOfType hole_ty+        hole_fv_set = fvVarSet hole_fvs+        anyFVMentioned :: Ct -> Bool+        anyFVMentioned ct = ctFreeVarSet ct `intersectsVarSet` hole_fv_set+        -- We filter out those constraints that have no variables (since+        -- they won't be solved by finding a type for the type variable+        -- representing the hole) and also other holes, since we're not+        -- trying to find hole fits for many holes at once.+        isRelevant ct = not (isEmptyVarSet (ctFreeVarSet ct))+                        && anyFVMentioned ct +-- We zonk the hole fits so that the output aligns with the rest+-- of the typed hole error message output.+zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit])+zonkSubs = zonkSubs' []+  where zonkSubs' zs env [] = return (env, reverse zs)+        zonkSubs' zs env (hf:hfs) = do { (env', z) <- zonkSub env hf+                                        ; zonkSubs' (z:zs) env' hfs }++        zonkSub :: TidyEnv -> HoleFit -> TcM (TidyEnv, HoleFit)+        zonkSub env hf@RawHoleFit{} = return (env, hf)+        zonkSub env hf@HoleFit{hfType = ty, hfMatches = m, hfWrap = wrp}+            = do { (env, ty') <- zonkTidyTcType env ty+                ; (env, m') <- zonkTidyTcTypes env m+                ; (env, wrp') <- zonkTidyTcTypes env wrp+                ; let zFit = hf {hfType = ty', hfMatches = m', hfWrap = wrp'}+                ; return (env, zFit ) }++-- | Sort by size uses as a measure for relevance the sizes of the different+-- types needed to instantiate the fit to the type of the hole.+-- This is much quicker than sorting by subsumption, and gives reasonable+-- results in most cases.+sortHoleFitsBySize :: [HoleFit] -> TcM [HoleFit]+sortHoleFitsBySize = return . sortOn sizeOfFit+  where sizeOfFit :: HoleFit -> TypeSize+        sizeOfFit = sizeTypes . nubBy tcEqType .  hfWrap++-- Based on a suggestion by phadej on #ghc, we can sort the found fits+-- by constructing a subsumption graph, and then do a topological sort of+-- the graph. This makes the most specific types appear first, which are+-- probably those most relevant. This takes a lot of work (but results in+-- much more useful output), and can be disabled by+-- '-fno-sort-valid-hole-fits'.+sortHoleFitsByGraph :: [HoleFit] -> TcM [HoleFit]+sortHoleFitsByGraph fits = go [] fits+  where tcSubsumesWCloning :: TcType -> TcType -> TcM Bool+        tcSubsumesWCloning ht ty = withoutUnification fvs (tcSubsumes ht ty)+          where fvs = tyCoFVsOfTypes [ht,ty]+        go :: [(HoleFit, [HoleFit])] -> [HoleFit] -> TcM [HoleFit]+        go sofar [] = do { traceTc "subsumptionGraph was" $ ppr sofar+                         ; return $ uncurry (++) $ partition hfIsLcl topSorted }+          where toV (hf, adjs) = (hf, hfId hf, map hfId adjs)+                (graph, fromV, _) = graphFromEdges $ map toV sofar+                topSorted = map ((\(h,_,_) -> h) . fromV) $ topSort graph+        go sofar (hf:hfs) =+          do { adjs <- filterM (tcSubsumesWCloning (hfType hf) . hfType) fits+             ; go ((hf, adjs):sofar) hfs }+ -- | tcFilterHoleFits filters the candidates by whether, given the implications -- and the relevant constraints, they can be made to match the type by -- running the type checker. Stops after finding limit matches.@@ -869,17 +896,6 @@      where fvs = mkFVs ref_vars `unionFV` hole_fvs `unionFV` tyCoFVsOfType ty            hole = typed_hole { th_hole = Nothing } -subsDiscardMsg :: SDoc-subsDiscardMsg =-    text "(Some hole fits suppressed;" <+>-    text "use -fmax-valid-hole-fits=N" <+>-    text "or -fno-max-valid-hole-fits)"--refSubsDiscardMsg :: SDoc-refSubsDiscardMsg =-    text "(Some refinement hole fits suppressed;" <+>-    text "use -fmax-refinement-hole-fits=N" <+>-    text "or -fno-max-refinement-hole-fits)"   -- | Checks whether a MetaTyVar is flexible or not.

@@ -4,10 +4,40 @@ -- + which calls 'GHC.Tc.Solver.simpl_top' module GHC.Tc.Errors.Hole where +import GHC.Types.Var ( Id ) import GHC.Tc.Types  ( TcM )-import GHC.Tc.Types.Constraint ( Ct, Hole, Implication )+import GHC.Tc.Types.Constraint ( Ct, CtLoc, Hole, Implication ) import GHC.Utils.Outputable ( SDoc ) import GHC.Types.Var.Env ( TidyEnv )+import GHC.Tc.Errors.Hole.FitTypes ( HoleFit, TypedHole, HoleFitCandidate )+import GHC.Tc.Utils.TcType ( TcType, TcSigmaType, Type, TcTyVar )+import GHC.Tc.Types.Evidence ( HsWrapper )+import GHC.Utils.FV ( FV )+import Data.Bool ( Bool )+import Data.Maybe ( Maybe )+import Data.Int ( Int )  findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Hole                   -> TcM (TidyEnv, SDoc)++tcCheckHoleFit :: TypedHole -> TcSigmaType -> TcSigmaType+               -> TcM (Bool, HsWrapper)++withoutUnification :: FV -> TcM a -> TcM a+tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool+tcFilterHoleFits :: Maybe Int -> TypedHole -> (TcType, [TcTyVar])+                 -> [HoleFitCandidate] -> TcM (Bool, [HoleFit])+getLocalBindings :: TidyEnv -> CtLoc -> TcM [Id]+addHoleFitDocs :: [HoleFit] -> TcM [HoleFit]++data HoleFitDispConfig+data HoleFitSortingAlg++pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc+getHoleFitSortingAlg :: TcM HoleFitSortingAlg+getHoleFitDispConfig :: TcM HoleFitDispConfig++relevantCts :: Type -> [Ct] -> [Ct]+zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit])+sortHoleFitsBySize :: [HoleFit] -> TcM [HoleFit]+sortHoleFitsByGraph :: [HoleFit] -> TcM [HoleFit]

@@ -5,7 +5,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -module GHC.Tc.Gen.Export (tcRnExports, exports_from_avail) where+module GHC.Tc.Gen.Export (rnExports, exports_from_avail) where  import GHC.Prelude @@ -151,45 +151,47 @@         --   it came from.  It's illegal to export two distinct things         --   that have the same occurrence name -tcRnExports :: Bool       -- False => no 'module M(..) where' header at all+rnExports :: Bool       -- False => no 'module M(..) where' header at all           -> Maybe (Located [LIE GhcPs]) -- Nothing => no explicit export list-          -> TcGblEnv           -> RnM TcGblEnv          -- Complains if two distinct exports have same OccName         -- Warns about identical exports.         -- Complains about exports items not in scope -tcRnExports explicit_mod exports-          tcg_env@TcGblEnv { tcg_mod     = this_mod,-                              tcg_rdr_env = rdr_env,-                              tcg_imports = imports,-                              tcg_src     = hsc_src }- = unsetWOptM Opt_WarnWarningsDeprecations $+rnExports explicit_mod exports+ = checkNoErrs $   -- Fail if anything in rnExports finds+                   -- an error fails, to avoid error cascade+   unsetWOptM Opt_WarnWarningsDeprecations $        -- Do not report deprecations arising from the export        -- list, to avoid bleating about re-exporting a deprecated        -- thing (especially via 'module Foo' export item)-   do   {-        ; dflags <- getDynFlags-        ; let is_main_mod = mainModIs dflags == this_mod-        ; let default_main = case mainFunIs dflags of-                 Just main_fun-                     | is_main_mod -> mkUnqual varName (fsLit main_fun)-                 _                 -> main_RDR_Unqual+   do   { dflags <- getDynFlags+        ; tcg_env <- getGblEnv+        ; let TcGblEnv { tcg_mod     = this_mod+                       , tcg_rdr_env = rdr_env+                       , tcg_imports = imports+                       , tcg_src     = hsc_src } = tcg_env+              default_main | mainModIs dflags == this_mod+                           , Just main_fun <- mainFunIs dflags+                           = mkUnqual varName (fsLit main_fun)+                           | otherwise+                           = main_RDR_Unqual         ; has_main <- (not . null) <$> lookupInfoOccRn default_main -- #17832+         -- If a module has no explicit header, and it has one or more main         -- functions in scope, then add a header like         -- "module Main(main) where ..."                               #13839         -- See Note [Modules without a module header]         ; let real_exports                  | explicit_mod = exports-                 | has_main-                          = Just (noLoc [noLoc (IEVar noExtField+                 | has_main = Just (noLoc [noLoc (IEVar noExtField                                      (noLoc (IEName $ noLoc default_main)))])-                        -- ToDo: the 'noLoc' here is unhelpful if 'main'-                        --       turns out to be out of scope+                              -- ToDo: the 'noLoc' here is unhelpful if 'main'+                              --       turns out to be out of scope                  | otherwise = Nothing +        -- Rename the export list         ; let do_it = exports_from_avail real_exports rdr_env imports this_mod         ; (rn_exports, final_avails)             <- if hsc_src == HsigFile@@ -198,19 +200,18 @@                             Just r  -> return r                             Nothing -> addMessages msgs >> failM                 else checkNoErrs do_it-        ; let final_ns     = availsToNameSetWithSelectors final_avails +        -- Final processing+        ; let final_ns = availsToNameSetWithSelectors final_avails+         ; traceRn "rnExports: Exports:" (ppr final_avails) -        ; let new_tcg_env =-                  tcg_env { tcg_exports    = final_avails,-                             tcg_rn_exports = case tcg_rn_exports tcg_env of+        ; return (tcg_env { tcg_exports    = final_avails+                          , tcg_rn_exports = case tcg_rn_exports tcg_env of                                                 Nothing -> Nothing-                                                Just _  -> rn_exports,-                            tcg_dus = tcg_dus tcg_env `plusDU`-                                      usesOnly final_ns }-        ; failIfErrsM-        ; return new_tcg_env }+                                                Just _  -> rn_exports+                          , tcg_dus = tcg_dus tcg_env `plusDU`+                                      usesOnly final_ns }) }  exports_from_avail :: Maybe (Located [LIE GhcPs])                          -- ^ 'Nothing' means no explicit export list@@ -616,7 +617,7 @@   = return ()    | otherwise-  = do { parent_ty_con <- tcLookupTyCon parent+  = do { parent_ty_con  <- tcLookupTyCon parent        ; mpat_syn_thing <- tcLookupGlobal mpat_syn          -- 1. Check that the Id was actually from a thing associated with patsyns@@ -806,7 +807,7 @@                 <+> text "is not the parent of the" <+> text what_is                 <+> quotes thing <> char '.'                 $$ text (capitalise what_is)-                <> text "s can only be exported with their parent type constructor."+                   <> text "s can only be exported with their parent type constructor."                 $$ (case parents of                       [] -> empty                       [_] -> text "Parent:"@@ -815,13 +816,13 @@ failWithDcErr :: Name -> Name -> SDoc -> [Name] -> TcM a failWithDcErr parent thing thing_doc parents = do   ty_thing <- tcLookupGlobal thing-  failWithTc $ dcErrMsg parent (tyThingCategory' ty_thing)+  failWithTc $ dcErrMsg parent (pp_category ty_thing)                         thing_doc (map ppr parents)   where-    tyThingCategory' :: TyThing -> String-    tyThingCategory' (AnId i)+    pp_category :: TyThing -> String+    pp_category (AnId i)       | isRecordSelector i = "record selector"-    tyThingCategory' i = tyThingCategory i+    pp_category i = tyThingCategory i   exportClashErr :: GlobalRdrEnv -> OccName

@@ -664,7 +664,11 @@ -- See Note [Running typed splices in the zonker] runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc) runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr)-  = setLclEnv lcl_env $ do {+  = do+      errs_var <- getErrsVar+      setLclEnv lcl_env $ setErrsVar errs_var $ do {+         -- Set the errs_var to the errs_var from the current context,+         -- otherwise error messages can go missing in GHCi (#19470)          zonked_ty <- zonkTcType res_ty        ; zonked_q_expr <- zonkTopLExpr q_expr         -- See Note [Collecting modFinalizers in typed splices].@@ -735,11 +739,17 @@                    -- is expected (#7276)     setStage (Splice isTypedSplice) $     do {    -- Typecheck the expression-         (expr', wanted) <- captureConstraints tc_action-       ; const_binds     <- simplifyTop wanted+         (mb_expr', wanted) <- tryCaptureConstraints tc_action+             -- If tc_action fails (perhaps because of insoluble constraints)+             -- we want to capture and report those constraints, else we may+             -- just get a silent failure (#20179). Hence the 'try' part. -          -- Zonk it and tie the knot of dictionary bindings-       ; return $ mkHsDictLet (EvBinds const_binds) expr' }+       ; const_binds <- simplifyTop wanted++       ; case mb_expr' of+            Nothing    -> failM   -- In this case simplifyTop should have+                                  -- reported some errors+            Just expr' -> return $ mkHsDictLet (EvBinds const_binds) expr' }  {- ************************************************************************

@@ -13,6 +13,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE MultiWayIf #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -56,7 +57,7 @@ import GHC.Tc.Gen.HsType import GHC.Tc.Validity( checkValidType ) import GHC.Tc.Gen.Match-import GHC.Tc.Utils.Unify( checkConstraints )+import GHC.Tc.Utils.Unify( checkConstraints, tcSubTypeSigma ) import GHC.Rename.HsType import GHC.Rename.Expr import GHC.Rename.Utils  ( HsDocContext(..) )@@ -129,7 +130,7 @@ import GHC.Types.Basic hiding( SuccessFlag(..) ) import GHC.Core.Coercion.Axiom import GHC.Types.Annotations-import Data.List ( find, sortBy, sort )+import Data.List ( sortBy, sort ) import Data.Ord import GHC.Data.FastString import GHC.Data.Maybe@@ -266,9 +267,16 @@           $ do { -- Rename and type check the declarations                  traceRn "rn1a" empty                ; tcg_env <- if isHsBootOrSig hsc_src-                            then tcRnHsBootDecls hsc_src local_decls+                            then do {+                              ; tcg_env <- tcRnHsBootDecls hsc_src local_decls+                              ; traceRn "rn4a: before exports" empty+                              ; tcg_env <- setGblEnv tcg_env $+                                           rnExports explicit_mod_hdr export_ies+                              ; traceRn "rn4b: after exports" empty+                              ; return tcg_env+                              }                             else {-# SCC "tcRnSrcDecls" #-}-                                 tcRnSrcDecls explicit_mod_hdr local_decls export_ies+                                 tcRnSrcDecls explicit_mod_hdr export_ies local_decls                 ; whenM (goptM Opt_DoCoreLinting) $                  do { let (warns, errs) = lintGblEnv (hsc_dflags hsc_env) tcg_env@@ -278,12 +286,7 @@                                      -- going to get in deeper trouble by proceeding                 ; setGblEnv tcg_env-                 $ do { -- Process the export list-                        traceRn "rn4a: before exports" empty-                      ; tcg_env <- tcRnExports explicit_mod_hdr export_ies-                                     tcg_env-                      ; traceRn "rn4b: after exports" empty-                      ; -- Compare hi-boot iface (if any) with the real thing+                 $ do { -- Compare hi-boot iface (if any) with the real thing                         -- Must be done after processing the exports                         tcg_env <- checkHiBootIface tcg_env boot_info                       ; -- The new type env is already available to stuff@@ -305,10 +308,14 @@                         reportUnusedNames tcg_env hsc_src                       ; -- add extra source files to tcg_dependent_files                         addDependentFiles src_files-                      ; tcg_env <- runTypecheckerPlugin mod_sum hsc_env tcg_env-                      ; -- Dump output and return-                        tcDump tcg_env-                      ; return tcg_env }+                        -- Ensure plugins run with the same tcg_env that we pass in+                      ; setGblEnv tcg_env+                        $ do { tcg_env <- runTypecheckerPlugin mod_sum hsc_env tcg_env+                             ; -- Dump output and return+                               tcDump tcg_env+                             ; return tcg_env+                             }+                      }                }         }       }@@ -403,104 +410,117 @@ -}  tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all-             -> [LHsDecl GhcPs]               -- Declarations              -> Maybe (Located [LIE GhcPs])+             -> [LHsDecl GhcPs]               -- Declarations              -> TcM TcGblEnv-tcRnSrcDecls explicit_mod_hdr decls export_ies+tcRnSrcDecls explicit_mod_hdr export_ies decls  = do { -- Do all the declarations       ; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls -        -- Check for the 'main' declaration-        -- Must do this inside the captureTopConstraints-        -- NB: always set envs *before* captureTopConstraints-      ; (tcg_env, lie_main) <- setEnvs (tcg_env, tcl_env) $-                               captureTopConstraints $-                               checkMain explicit_mod_hdr export_ies--      ; setEnvs (tcg_env, tcl_env) $ do {--             --         Simplify constraints-             ---             -- We do this after checkMain, so that we use the type info-             -- that checkMain adds-             ---             -- We do it with both global and local env in scope:-             --  * the global env exposes the instances to simplifyTop-             --  * the local env exposes the local Ids to simplifyTop,-             --    so that we get better error messages (monomorphism restriction)+      ------ Simplify constraints ---------+      --+      -- We do this after checkMainType, so that we use the type+      -- info that checkMainType adds+      --+      -- We do it with both global and local env in scope:+      --  * the global env exposes the instances to simplifyTop,+      --    and affects how names are rendered in error messages+      --  * the local env exposes the local Ids to simplifyTop,+      --    so that we get better error messages (monomorphism restriction)       ; new_ev_binds <- {-# SCC "simplifyTop" #-}-                        simplifyTop (lie `andWC` lie_main)+                        setEnvs (tcg_env, tcl_env) $+                        do { lie_main <- checkMainType tcg_env+                           ; simplifyTop (lie `andWC` lie_main) }          -- Emit Typeable bindings-      ; tcg_env <- mkTypeableBinds-+      ; tcg_env <- setGblEnv tcg_env $+                   mkTypeableBinds        ; traceTc "Tc9" empty -      ; failIfErrsM     -- Don't zonk if there have been errors-                        -- It's a waste of time; and we may get debug warnings-                        -- about strangely-typed TyCons!-      ; traceTc "Tc10" empty-         -- Zonk the final code.  This must be done last.         -- Even simplifyTop may do some unification.         -- This pass also warns about missing type signatures-      ; (bind_env, ev_binds', binds', fords', imp_specs', rules')+      ; (id_env, ev_binds', binds', fords', imp_specs', rules')             <- zonkTcGblEnv new_ev_binds tcg_env -        -- Finalizers must run after constraints are simplified, or some types-        -- might not be complete when using reify (see #12777).-        -- and also after we zonk the first time because we run typed splices-        -- in the zonker which gives rise to the finalisers.-      ; (tcg_env_mf, _) <- setGblEnv (clearTcGblEnv tcg_env)-                                     run_th_modfinalizers+      --------- Run finalizers --------------+      -- Finalizers must run after constraints are simplified, lest types+      --    might not be complete when using reify (see #12777).+      -- and also after we zonk the first time because we run typed splices+      --    in the zonker which gives rise to the finalisers.+      ; let -- init_tcg_env:+            --   * Remove accumulated bindings, rules and so on from+            --     TcGblEnv.  They are now in ev_binds', binds', etc.+            --   * Add the zonked Ids from the value bindings to tcg_type_env+            --     Up to now these Ids are only in tcl_env's type-envt+            init_tcg_env = tcg_env { tcg_binds     = emptyBag+                                   , tcg_ev_binds  = emptyBag+                                   , tcg_imp_specs = []+                                   , tcg_rules     = []+                                   , tcg_fords     = []+                                   , tcg_type_env  = tcg_type_env tcg_env+                                                     `plusTypeEnv` id_env }+      ; (tcg_env, tcl_env) <- setGblEnv init_tcg_env+                              run_th_modfinalizers       ; finishTH       ; traceTc "Tc11" empty -      ; -- zonk the new bindings arising from running the finalisers.-        -- This won't give rise to any more finalisers as you can't nest-        -- finalisers inside finalisers.-      ; (bind_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf)-            <- zonkTcGblEnv emptyBag tcg_env_mf+      --------- Deal with the exports ----------+      -- Can't be done earlier, because the export list must "see"+      -- the declarations created by the finalizers+      ; tcg_env <- setEnvs (tcg_env, tcl_env) $+                   rnExports explicit_mod_hdr export_ies +      --------- Emit the ':Main.main = runMainIO main' declaration ----------+      -- Do this /after/ rnExports, so that it can consult+      -- the tcg_exports created by rnExports+      ; (tcg_env, main_ev_binds)+           <- setEnvs (tcg_env, tcl_env) $+              do { (tcg_env, lie) <- captureTopConstraints $+                                     checkMain explicit_mod_hdr export_ies+                 ; ev_binds <- simplifyTop lie+                 ; return (tcg_env, ev_binds) } -      ; let { final_type_env = plusTypeEnv (tcg_type_env tcg_env)-                                (plusTypeEnv bind_env_mf bind_env)-            ; tcg_env' = tcg_env_mf-                          { tcg_binds    = binds' `unionBags` binds_mf,-                            tcg_ev_binds = ev_binds' `unionBags` ev_binds_mf ,-                            tcg_imp_specs = imp_specs' ++ imp_specs_mf ,-                            tcg_rules    = rules' ++ rules_mf ,-                            tcg_fords    = fords' ++ fords_mf } } ;+      ---------- Final zonking ---------------+      -- Zonk the new bindings arising from running the finalisers,+      -- and main. This won't give rise to any more finalisers as you+      -- can't nest finalisers inside finalisers.+      ; (id_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf)+            <- zonkTcGblEnv main_ev_binds tcg_env -      ; setGlobalTypeEnv tcg_env' final_type_env+      ; let { !final_type_env = tcg_type_env tcg_env+                                `plusTypeEnv` id_env_mf+              -- Add the zonked Ids from the value bindings (they were in tcl_env)+              -- Force !final_type_env, lest we retain an old reference+              -- to the previous tcg_env -   } }+            ; tcg_env' = tcg_env+                          { tcg_binds     = binds'    `unionBags` binds_mf+                          , tcg_ev_binds  = ev_binds' `unionBags` ev_binds_mf+                          , tcg_imp_specs = imp_specs' ++ imp_specs_mf+                          , tcg_rules     = rules'     ++ rules_mf+                          , tcg_fords     = fords'     ++ fords_mf } } ; +      ; setGlobalTypeEnv tcg_env' final_type_env+   }+ zonkTcGblEnv :: Bag EvBind -> TcGblEnv              -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc,                        [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc])-zonkTcGblEnv new_ev_binds tcg_env =-  let TcGblEnv {   tcg_binds     = binds,-                   tcg_ev_binds  = cur_ev_binds,-                   tcg_imp_specs = imp_specs,-                   tcg_rules     = rules,-                   tcg_fords     = fords } = tcg_env--      all_ev_binds = cur_ev_binds `unionBags` new_ev_binds--  in {-# SCC "zonkTopDecls" #-}-      zonkTopDecls all_ev_binds binds rules imp_specs fords----- | Remove accumulated bindings, rules and so on from TcGblEnv-clearTcGblEnv :: TcGblEnv -> TcGblEnv-clearTcGblEnv tcg_env-  = tcg_env { tcg_binds    = emptyBag,-              tcg_ev_binds = emptyBag ,-              tcg_imp_specs = [],-              tcg_rules    = [],-              tcg_fords    = [] }+zonkTcGblEnv ev_binds tcg_env@(TcGblEnv { tcg_binds     = binds+                                        , tcg_ev_binds  = cur_ev_binds+                                        , tcg_imp_specs = imp_specs+                                        , tcg_rules     = rules+                                        , tcg_fords     = fords })+  = {-# SCC "zonkTopDecls" #-}+    setGblEnv tcg_env $ -- This sets the GlobalRdrEnv which is used when rendering+                        --   error messages during zonking (notably levity errors)+    do { failIfErrsM    -- Don't zonk if there have been errors+                        -- It's a waste of time; and we may get debug warnings+                        -- about strangely-typed TyCons!+       ; let all_ev_binds = cur_ev_binds `unionBags` ev_binds+       ; zonkTopDecls all_ev_binds binds rules imp_specs fords }  -- | Runs TH finalizers and renames and typechecks the top-level declarations -- that they could introduce.@@ -604,12 +624,9 @@                ; (spliced_decls, splice_fvs) <- rnTopSpliceDecls splice                   -- 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, lie2)+               ; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $+                 addTopEvBinds ev_binds1                             $+                 tc_rn_src_decls (spliced_decls ++ rest_ds)                }           }       }@@ -1718,245 +1735,246 @@ ************************************************************************ -} +checkMainType :: TcGblEnv -> TcRn WantedConstraints+-- If this is the Main module, and it defines a function main,+--   check that its type is of form IO tau.+-- If not, do nothing+-- See Note [Dealing with main]+checkMainType tcg_env+  = do { dflags <- getDynFlags+       ; if tcg_mod tcg_env /= mainModIs dflags+         then return emptyWC else++    do { rdr_env <- getGlobalRdrEnv+       ; let main_occ  = getMainOcc dflags+             main_gres = lookupGlobalRdrEnv rdr_env main_occ+       ; case filter isLocalGRE main_gres of {+            []         -> return emptyWC ;+            (_:_:_)    -> return emptyWC ;+            [main_gre] ->++    do { let main_name = gre_name main_gre+             ctxt      = FunSigCtxt main_name False+       ; main_id   <- tcLookupId main_name+       ; (io_ty,_) <- getIOType+       ; (_, lie)  <- captureTopConstraints       $+                      setMainCtxt main_name io_ty $+                      tcSubTypeSigma ctxt (idType main_id) io_ty+       ; return lie } } } }+ checkMain :: Bool  -- False => no 'module M(..) where' header at all           -> Maybe (Located [LIE GhcPs])  -- Export specs of Main module           -> TcM TcGblEnv--- If we are in module Main, check that 'main' is defined and exported.+-- If we are in module Main, check that 'main' is exported,+-- and generate the runMainIO binding that calls it+-- See Note [Dealing with main] checkMain explicit_mod_hdr export_ies- = do   { dflags  <- getDynFlags-        ; tcg_env <- getGblEnv-        ; check_main dflags tcg_env explicit_mod_hdr export_ies }--check_main :: DynFlags -> TcGblEnv -> Bool -> Maybe (Located [LIE GhcPs])-           -> TcM TcGblEnv-check_main dflags tcg_env explicit_mod_hdr export_ies- | mod /= main_mod- = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >>-   return tcg_env-- | otherwise-   -- Compare the list of main functions in scope with those-   --   specified in the export list.- = do mains_all <- lookupInfoOccRn main_fn-                    -- get all 'main' functions in scope-                    -- They may also be imported from other modules!-      case exportedMains of -- check the main(s) specified in the export list-        [ ] -> do-          -- The module has no main functions in the export spec, so we must give-          -- some kind of error message. The tricky part is giving an error message-          -- that accurately characterizes what the problem is.-          -- See Note [Main module without a main function in the export spec]-          traceTc "checkMain no main module exported" ppr_mod_mainfn-          complain_no_main-          -- In order to reduce the number of potential error messages, we check-          -- to see if there are any main functions defined (but not exported)...-          case getSomeMain mains_all of-            Nothing -> return tcg_env-              -- ...if there are no such main functions, there is nothing we can do...-            Just some_main -> use_as_main some_main-                -- ...if there is such a main function, then communicate this to the-                -- typechecker. This can prevent a spurious "Ambiguous type variable"-                -- error message in certain cases, as described in-                -- Note [Main module without a main function in the export spec].-        _ -> do    -- The module has one or more main functions in the export spec-          let mains = filterInsMains exportedMains mains_all-          case mains of-            [] -> do  ---              traceTc "checkMain fail" ppr_mod_mainfn-              complain_no_main-              return tcg_env-            [main_name] -> use_as_main main_name-            _ -> do           -- multiple main functions are exported-              addAmbiguousNameErr main_fn          -- issue error msg-              return tcg_env-  where-    mod         = tcg_mod tcg_env-    main_mod    = mainModIs dflags-    main_mod_nm = moduleName main_mod-    main_fn     = getMainFun dflags-    occ_main_fn = occName main_fn-    interactive = ghcLink dflags == LinkInMemory-    exportedMains = selExportMains export_ies-    ppr_mod_mainfn = ppr main_mod <+> ppr main_fn--    -- There is a single exported 'main' function.-    use_as_main :: Name -> TcM TcGblEnv-    use_as_main main_name = do-        { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn)-        ; let loc       = srcLocSpan (getSrcLoc main_name)-        ; ioTyCon <- tcLookupTyCon ioTyConName-        ; res_ty <- newFlexiTyVarTy liftedTypeKind-        ; let io_ty = mkTyConApp ioTyCon [res_ty]-              skol_info = SigSkol (FunSigCtxt main_name False) io_ty []-              main_expr_rn = L loc (HsVar noExtField (L loc main_name))-        ; (ev_binds, main_expr)-               <- checkConstraints skol_info [] [] $-                  addErrCtxt mainCtxt    $-                  tcCheckMonoExpr main_expr_rn io_ty--                -- See Note [Root-main Id]-                -- Construct the binding-                --      :Main.main :: IO res_ty = runMainIO res_ty main-        ; run_main_id <- tcLookupId runMainIOName-        ; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN-                                   (mkVarOccFS (fsLit "main"))-                                   (getSrcSpan main_name)-              ; root_main_id = Id.mkExportedVanillaId root_main_name-                                                      (mkTyConApp ioTyCon [res_ty])-              ; co  = mkWpTyApps [res_ty]-              -- The ev_binds of the `main` function may contain deferred-              -- type error when type of `main` is not `IO a`. The `ev_binds`-              -- must be put inside `runMainIO` to ensure the deferred type-              -- error can be emitted correctly. See #13838.-              ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) $-                        mkHsDictLet ev_binds main_expr-              ; main_bind = mkVarBind root_main_id rhs }+ = do { dflags <- getDynFlags+      ; tcg_env <- getGblEnv -        ; return (tcg_env { tcg_main  = Just main_name,-                            tcg_binds = tcg_binds tcg_env-                                        `snocBag` main_bind,-                            tcg_dus   = tcg_dus tcg_env-                                        `plusDU` usesOnly (unitFV main_name)-                        -- Record the use of 'main', so that we don't-                        -- complain about it being defined but not used-        })}+      ; let main_mod    = mainModIs dflags+            main_occ    = getMainOcc dflags -    complain_no_main = unless (interactive && not explicit_mod_hdr)-                              (addErrTc noMainMsg)                  -- #12906-        -- Without an explicit module header...-          -- in interactive mode, don't worry about the absence of 'main'.-          -- in other modes, add error message and go on with typechecking.+            exported_mains :: [Name]+            -- Exported things that are called 'main'+            exported_mains  = [ name | avail <- tcg_exports tcg_env+                                     , name  <- availNames avail+                                     , nameOccName name == main_occ ] -    mainCtxt  = text "When checking the type of the" <+> pp_main_fn-    noMainMsg = text "The" <+> pp_main_fn-                <+> text "is not" <+> text defOrExp <+> text "module"-                <+> quotes (ppr main_mod)-    defOrExp  = if null exportedMains then "exported by" else "defined in"+      ; if | tcg_mod tcg_env /= main_mod+           -> -- Not the main module+              return tcg_env -    pp_main_fn = ppMainFn main_fn+           | [main_name] <- exported_mains+           -> -- The module indeed exports a function called 'main'+              generateMainBinding tcg_env main_name -    -- Select the main functions from the export list.-    -- Only the module name is needed, the function name is fixed.-    selExportMains :: Maybe (Located [LIE GhcPs]) -> [ModuleName]    -- #16453-    selExportMains Nothing = [main_mod_nm]-        -- no main specified, but there is a header.-    selExportMains (Just exps) = fmap fst $-        filter (\(_,n) -> n == occ_main_fn ) texp+           | otherwise+           -> ASSERT( null exported_mains )+              -- A fully-checked export list can't contain more+              -- than one function with the same OccName+              do { complain_no_main dflags main_mod main_occ+                 ; return tcg_env } }+  where+    complain_no_main dflags main_mod main_occ+      = unless (interactive && not explicit_mod_hdr) $+        addErrTc (noMainMsg main_mod main_occ)          -- #12906       where-        ies = fmap unLoc $ unLoc exps-        texp = mapMaybe transExportIE ies--    -- Filter all main functions in scope that match the export specs-    filterInsMains :: [ModuleName] -> [Name] -> [Name]               -- #16453-    filterInsMains export_mains inscope_mains =-      [mod | mod <- inscope_mains,-          (moduleName . nameModule) mod `elem` export_mains]+        interactive = ghcLink dflags == LinkInMemory+        -- Without an explicit module header...+        -- in interactive mode, don't worry about the absence of 'main'.+        -- in other modes, add error message and go on with typechecking. -    -- Transform an export_ie to a (ModuleName, OccName) pair.-    -- 'IEVar' constructors contain exported values (functions), eg '(Main.main)'-    -- 'IEModuleContents' constructors contain fully exported modules, eg '(Main)'-    -- All other 'IE...' constructors are not used and transformed to Nothing.-    transExportIE :: IE GhcPs -> Maybe (ModuleName, OccName)         -- #16453-    transExportIE (IEVar _  var) = isQual_maybe $-         upqual $ ieWrappedName $ unLoc var-       where-         -- A module name is always needed, so qualify 'UnQual' rdr names.-         upqual (Unqual occ) = Qual main_mod_nm occ-         upqual rdr = rdr-    transExportIE (IEModuleContents _ mod) = Just (unLoc mod, occ_main_fn)-    transExportIE _ = Nothing+    noMainMsg main_mod main_occ+      = text "The" <+> ppMainFn main_occ+        <+> text "is not" <+> text defOrExp <+> text "module"+        <+> quotes (ppr main_mod) -    -- Get a main function that is in scope.-    -- See Note [Main module without a main function in the export spec]-    getSomeMain :: [Name] -> Maybe Name                            -- #16453-    getSomeMain all_mains = case all_mains of-        []  -> Nothing                -- No main function in scope-        [m] -> Just m                 -- Just one main function in scope-        _   -> case mbMainOfMain of-          Nothing -> listToMaybe all_mains -- Take the first main function in scope or Nothing-          _       -> mbMainOfMain          -- Take the Main module's main function or Nothing-      where-        mbMainOfMain = find (\n -> (moduleName . nameModule) n == main_mod_nm )-                          all_mains         -- the main function of the Main module+    defOrExp | explicit_export_list = "exported by"+             | otherwise            = "defined in"+    explicit_export_list = explicit_mod_hdr && isJust export_ies  -- | Get the unqualified name of the function to use as the \"main\" for the main module. -- Either returns the default name or the one configured on the command line with -main-is-getMainFun :: DynFlags -> RdrName-getMainFun dflags = case mainFunIs dflags of-                      Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))-                      Nothing -> main_RDR_Unqual+getMainOcc :: DynFlags -> OccName+getMainOcc dflags = case mainFunIs dflags of+                      Just fn -> mkVarOccFS (mkFastString fn)+                      Nothing -> mainOcc -ppMainFn :: RdrName -> SDoc-ppMainFn main_fn-  | rdrNameOcc main_fn == mainOcc-  = text "IO action" <+> quotes (ppr main_fn)+ppMainFn :: OccName -> SDoc+ppMainFn main_occ+  | main_occ == mainOcc+  = text "IO action" <+> quotes (ppr main_occ)   | otherwise-  = text "main IO action" <+> quotes (ppr main_fn)+  = text "main IO action" <+> quotes (ppr main_occ)  mainOcc :: OccName mainOcc = mkVarOccFS (fsLit "main") -{--Note [Root-main Id]-~~~~~~~~~~~~~~~~~~~-The function that the RTS invokes is always :Main.main, which we call-root_main_id.  (Because GHC allows the user to have a module not-called Main as the main module, we can't rely on the main function-being called "Main.main".  That's why root_main_id has a fixed module-":Main".)+generateMainBinding :: TcGblEnv -> Name -> TcM TcGblEnv+-- There is a single exported 'main' function, called 'foo' (say),+-- which may be locally defined or imported+-- Define and typecheck the binding+--     :Main.main :: IO res_ty = runMainIO res_ty foo+-- This wraps the user's main function in the top-level stuff+-- defined in runMainIO (eg catching otherwise un-caught exceptions)+-- See Note [Dealing with main]+generateMainBinding tcg_env main_name = do+    { traceTc "checkMain found" (ppr main_name)+    ; (io_ty, res_ty) <- getIOType+    ; let loc = getSrcSpan main_name+          main_expr_rn = L loc (HsVar noExtField (L loc main_name))+    ; (ev_binds, main_expr) <- setMainCtxt main_name io_ty $+                               tcCheckMonoExpr main_expr_rn io_ty -This is unusual: it's a LocalId whose Name has a Module from another-module. Tiresomely, we must filter it out again in GHC.Iface.Make, less we-get two defns for 'main' in the interface file!+            -- See Note [Root-main Id]+            -- Construct the binding+            --      :Main.main :: IO res_ty = runMainIO res_ty main+    ; run_main_id <- tcLookupId runMainIOName+    ; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN+                               (mkVarOccFS (fsLit "main"))+                               (getSrcSpan main_name)+          ; root_main_id = Id.mkExportedVanillaId root_main_name io_ty+          ; co  = mkWpTyApps [res_ty]+          -- The ev_binds of the `main` function may contain deferred+          -- type errors when type of `main` is not `IO a`. The `ev_binds`+          -- must be put inside `runMainIO` to ensure the deferred type+          -- error can be emitted correctly. See #13838.+          ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) $+                    mkHsDictLet ev_binds main_expr+          ; main_bind = mkVarBind root_main_id rhs } +    ; return (tcg_env { tcg_main  = Just main_name+                      , tcg_binds = tcg_binds tcg_env+                                    `snocBag` main_bind+                      , tcg_dus   = tcg_dus tcg_env+                                    `plusDU` usesOnly (unitFV main_name) })+                    -- Record the use of 'main', so that we don't+                    -- complain about it being defined but not used+    } -Note [Main module without a main function in the export spec]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Giving accurate error messages for a Main module that does not export a main-function is surprisingly tricky. To see why, consider a module in a file-`Foo.hs` that has no `main` function in the explicit export specs of the module-header:+getIOType :: TcM (TcType, TcType)+-- Return (IO alpha, alpha) for fresh alpha+getIOType = do { ioTyCon <- tcLookupTyCon ioTyConName+               ; res_ty <- newFlexiTyVarTy liftedTypeKind+               ; return (mkTyConApp ioTyCon [res_ty], res_ty) } -    module Main () where-    foo = return ()+setMainCtxt :: Name -> TcType -> TcM a -> TcM (TcEvBinds, a)+setMainCtxt main_name io_ty thing_inside+  = setSrcSpan (getSrcSpan main_name) $+    addErrCtxt main_ctxt              $+    checkConstraints skol_info [] []  $  -- Builds an implication if necessary+    thing_inside                         -- e.g. with -fdefer-type-errors+  where+    skol_info = SigSkol (FunSigCtxt main_name False) io_ty []+    main_ctxt = text "When checking the type of the"+                <+> ppMainFn (nameOccName main_name) -This does not export a main function and therefore should be rejected, per-chapter 5 of the Haskell Report 2010:+{- Note [Dealing with main]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Dealing with the 'main' declaration is surprisingly tricky. Here are+the moving parts: -   A Haskell program is a collection of modules, one of which, by convention,-   must be called Main and must export the value main. The value of the-   program is the value of the identifier main in module Main, which must be-   a computation of type IO τ for some type τ.+* The flag -main-is=M.foo allows you to set the main module to 'M',+  and the main function to 'foo'.  We access them through+      mainModIs  :: DynFlags -> Module   -- returns M+      getMainOcc :: DynFlags -> OccName  -- returns foo+  Of course usually M = Main, and foo = main. -In fact, when you compile the program above using `ghc Foo.hs`, you will-actually get *two* errors:+* checkMainType: when typechecking module M, we add an extra check that+    foo :: IO tau, for some type tau.+  This avoids getting ambiguous-type errors from the monomorphism restriction+  applying to things like+      main = return ()+  Note that checkMainType does not consult the export list because+  we have not yet done rnExports (and can't do it until later). - - The IO action ‘main’ is not defined in module ‘Main’+* rnExports: checks the export list.  Very annoyingly, we can only do+  this after running any finalisers, which may add new declarations.+  That's why checkMainType and checkMain have to be separate. - - Ambiguous type variable ‘m0’ arising from a use of ‘return’-   prevents the constraint ‘(Monad m0)’ from being solved.+* checkMain: does two things:+  - check that the export list does indeed export something called 'foo'+  - generateMainBinding: generate the root-main binding+       :Main.main = runMainIO M.foo+  See Note [Root-main id] -The first error is self-explanatory, while the second error message occurs-due to the monomorphism restriction.+An annoying consequence of having both checkMainType and checkMain is+that, when (but only when) -fdefer-type-errors is on, we may report an+ill-typed 'main' twice (as warnings): once in checkMainType and once+in checkMain. See test typecheck/should_fail/T13292. -Now consider what would happen if the program above were compiled with-`ghc -main-is foo Foo`. The has the effect of `foo` being designated as the-main function. The program will still be rejected since it does not export-`foo` (and therefore does not export its main function), but there is one-important difference: `foo` will be checked against the type `IO τ`. As a-result, we would *not* expect the monomorphism restriction error message-to occur, since the typechecker should have no trouble figuring out the type-of `foo`. In other words, we should only throw the former error message,-not the latter.+We have the following tests to check this processing:+----------------+----------------------------------------------------------------------------------++                |                                  Module Header:                                  |+                +-------------+-------------+-------------+-------------+-------------+------------++                | module      | module Main | <No Header> | module Main |module       |module Main |+                |  Main(main) |             |             |   (module X)|   Main ()   |  (Sub.main)|+----------------+==================================================================================++`main` function | ERROR:      | Main.main   | ERROR:      | Main.main   | ERROR:      | Sub.main   |+in Main module  |  Ambiguous  |             |  Ambiguous  |             |  `main` not |            |+and in imported |             |             |             |             |  exported   |            |+module Sub.     | T19397E1    | T16453M0    | T19397E2    | T16453M3    |             | T16453M1   |+                |             |             |             | X = Main    | Remark 2)   |            |+----------------+-------------+-------------+-------------+-------------+-------------+------------++`main`function  | Sub.main    | ERROR:      | Sub.main    | Sub.main    | ERROR:      | Sub.main   |+only in imported|             | No `main` in|             |             |  `main` not |            |+submodule Sub.  |             |   `Main`    |             |             |  exported   |            |+                | T19397M0    | T16453E1    | T19397M1    | T16453M4    |             | T16453M5   |+                |             |             |             | X = Sub     | Remark 2)   |            |+----------------+-------------+-------------+-------------+-------------+-------------+------------++`foo` function  | Sub.foo     | ERROR:      | Sub.foo     | Sub.foo     | ERROR:      | Sub.foo    |+in submodule    |             | No `foo` in |             |             |  `foo` not  |            |+Sub.            |             |   `Main`    |             |             |  exported   |            |+GHC option:     |             |             |             |             |             |            |+  -main-is foo  | T19397M2    | T19397E3    | T19397M3    | T19397M4    | T19397E4    | T16453M6   |+                | Remark 1)   |             |             | X = Sub     |             | Remark 3)  |+----------------+-------------+-------------+-------------+-------------+-------------+------------+ -The implementation uses the function `getSomeMain` to find a potential main-function that is defined but not exported. If one is found, it is passed to-`use_as_main` to inform the typechecker that the main function should be of-type `IO τ`. See also the `T414` and `T17171a` test cases for similar examples-of programs whose error messages are influenced by the situation described in-this Note.+Remarks:+* The first line shows the exported `main` function or the error.+* The second line shows the coresponding test case.+* The module `Sub` contains the following functions:+     main :: IO ()+     foo :: IO ()+* Remark 1) Here the header is `Main (foo)`.+* Remark 2) Here we have no extra test case. It would exercise the same code path as `T19397E4`.+* Remark 3) Here the header is `Main (Sub.foo)`.  +Note [Root-main Id]+~~~~~~~~~~~~~~~~~~~+The function that the RTS invokes is always :Main.main, which we call+root_main_id.  (Because GHC allows the user to have a module not+called Main as the main module, we can't rely on the main function+being called "Main.main".  That's why root_main_id has a fixed module+":Main".)++This is unusual: it's a LocalId whose Name has a Module from another+module. Tiresomely, we must filter it out again in GHC.Iface.Make, less we+get two defns for 'main' in the interface file!++ ********************************************************* *                                                       *                 GHCi stuff@@ -2711,7 +2729,7 @@            -> IO (Messages, Maybe TcGblEnv) tcRnDeclsi hsc_env local_decls   = runTcInteractive hsc_env $-    tcRnSrcDecls False local_decls Nothing+    tcRnSrcDecls False Nothing local_decls  externaliseAndTidyId :: Module -> Id -> TcM Id externaliseAndTidyId this_mod id

@@ -499,12 +499,32 @@ data InteractResult    = KeepInert   -- Keep the inert item, and solve the work item from it                  -- (if the latter is Wanted; just discard it if not)-   | KeepWork    -- Keep the work item, and solve the intert item from it+   | KeepWork    -- Keep the work item, and solve the inert item from it +   | KeepBoth    -- See Note [KeepBoth]+ instance Outputable InteractResult where+  ppr KeepBoth  = text "keep both"   ppr KeepInert = text "keep inert"   ppr KeepWork  = text "keep work-item" +{- Note [KeepBoth]+~~~~~~~~~~~~~~~~~~+Consider+   Inert:     [WD] C ty1 ty2+   Work item: [D]  C ty1 ty2++Here we can simply drop the work item. But what about+   Inert:     [W] C ty1 ty2+   Work item: [D] C ty1 ty2++Here we /cannot/ drop the work item, becuase we lose the [D] form, and+that is essential for e.g. fundeps, see isImprovable.  We could zap+the inert item to [WD], but the simplest thing to do is simply to keep+both. (They probably started as [WD] and got split; this is relatively+rare and it doesn't seem worth trying to put them back together again.)+-}+ solveOneFromTheOther :: CtEvidence  -- Inert                      -> CtEvidence  -- WorkItem                      -> TcS InteractResult@@ -516,22 +536,37 @@ -- two wanteds into one by solving one from the other  solveOneFromTheOther ev_i ev_w-  | isDerived ev_w         -- Work item is Derived; just discard it-  = return KeepInert+  | CtDerived {} <- ev_w         -- Work item is Derived+  = case ev_i of+      CtWanted { ctev_nosh = WOnly } -> return KeepBoth+      _                              -> return KeepInert -  | isDerived ev_i     -- The inert item is Derived, we can just throw it away,-  = return KeepWork    -- The ev_w is inert wrt earlier inert-set items,-                       -- so it's safe to continue on from this point+  | CtDerived {} <- ev_i         -- Inert item is Derived+  = case ev_w of+      CtWanted { ctev_nosh = WOnly } -> return KeepBoth+      _                              -> return KeepWork+              -- The ev_w is inert wrt earlier inert-set items,+              -- so it's safe to continue on from this point +  -- After this, neither ev_i or ev_w are Derived   | CtWanted { ctev_loc = loc_w } <- ev_w   , prohibitedSuperClassSolve (ctEvLoc ev_i) loc_w   = -- inert must be Given     do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w)        ; return KeepWork } -  | CtWanted {} <- ev_w+  | CtWanted { ctev_nosh = nosh_w } <- ev_w        -- Inert is Given or Wanted-  = return KeepInert+  = case ev_i of+      CtWanted { ctev_nosh = WOnly }+          | WDeriv <- nosh_w -> return KeepWork+      _                      -> return KeepInert+      -- Consider work  item [WD] C ty1 ty2+      --          inert item [W]  C ty1 ty2+      -- Then we must keep the work item.  But if the+      -- work item was       [W]  C ty1 ty2+      -- then we are free to discard the work item in favour of inert+      -- Remember, no Deriveds at this point    -- From here on the work-item is Given @@ -703,6 +738,7 @@   = do { what_next <- solveOneFromTheOther ev_i ev_w        ; traceTcS "iteractIrred" (ppr workItem $$ ppr what_next $$ ppr ct_i)        ; case what_next of+            KeepBoth  -> continueWith workItem             KeepInert -> do { setEvBindIfWanted ev_w (swap_me swap ev_i)                             ; return (Stop ev_w (text "Irred equal" <+> parens (ppr what_next))) }             KeepWork ->  do { setEvBindIfWanted ev_i (swap_me swap ev_w)@@ -1025,7 +1061,8 @@  interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct) interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys })-  | Just ev_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys+  | Just ct_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys+  , let ev_i = ctEvidence ct_i   = -- There is a matching dictionary in the inert set     do { -- First to try to solve it /completely/ from top level instances          -- See Note [Shortcut solving]@@ -1040,6 +1077,7 @@          what_next <- solveOneFromTheOther ev_i ev_w        ; traceTcS "lookupInertDict" (ppr what_next)        ; case what_next of+           KeepBoth  -> continueWith workItem            KeepInert -> do { setEvBindIfWanted ev_w (ctEvTerm ev_i)                            ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) }            KeepWork  -> do { setEvBindIfWanted ev_i (ctEvTerm ev_w)

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, DeriveFunctor, TypeFamilies #-}+{-# LANGUAGE CPP, DeriveFunctor, TypeFamilies, ScopedTypeVariables #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -1648,7 +1648,7 @@   add_item ics item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })-  = ics { inert_dicts = addDict (inert_dicts ics) cls tys item+  = ics { inert_dicts = addDictCt (inert_dicts ics) cls tys item         , inert_count = bumpUnsolvedCount ev (inert_count ics) }  add_item _ item@@ -1912,7 +1912,7 @@ -------------- addInertSafehask :: InertCans -> Ct -> InertCans addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })-  = ics { inert_safehask = addDict (inert_dicts ics) cls tys item }+  = ics { inert_safehask = addDictCt (inert_dicts ics) cls tys item }  addInertSafehask _ item   = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item@@ -2056,7 +2056,7 @@      add :: Ct -> DictMap Ct -> DictMap Ct     add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts-        = addDict dicts cls tys ct+        = addDictCt dicts cls tys ct     add ct _ = pprPanic "getPendingScDicts" (ppr ct)      get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)@@ -2372,16 +2372,16 @@   | ClassPred cls tys <- classifyPredType pty   = do { inerts <- getTcSInerts        ; return (lookupSolvedDict inerts loc cls tys `mplus`-                 lookupInertDict (inert_cans inerts) loc cls tys) }+                 fmap ctEvidence (lookupInertDict (inert_cans inerts) loc cls tys)) }   | otherwise -- NB: No caching for equalities, IPs, holes, or errors   = return Nothing  -- | Look up a dictionary inert. NB: the returned 'CtEvidence' might not -- match the input exactly. Note [Use loose types in inert set].-lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe CtEvidence+lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe Ct lookupInertDict (IC { inert_dicts = dicts }) loc cls tys   = case findDict dicts loc cls tys of-      Just ct -> Just (ctEvidence ct)+      Just ct -> Just ct       _       -> Nothing  -- | Look up a solved inert. NB: the returned 'CtEvidence' might not@@ -2446,6 +2446,12 @@   where     alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM)) +alterTcApp :: forall a. TcAppMap a -> Unique -> [Type] -> XT a -> TcAppMap a+alterTcApp m cls tys xt_ct = alterUDFM alter_tm m cls+  where+    alter_tm :: Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a)+    alter_tm mb_tm = Just (alterTM tys xt_ct (mb_tm `orElse` emptyTM))+ -- mapTcApp :: (a->b) -> TcAppMap a -> TcAppMap b -- mapTcApp f = mapUDFM (mapTM f) @@ -2546,6 +2552,26 @@  addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a addDict m cls tys item = insertTcApp m (getUnique cls) tys item++addDictCt :: DictMap Ct -> Class -> [Type] -> Ct -> DictMap Ct+-- Like addDict, but combines [W] and [D] to [WD]+-- See Note [KeepBoth] in GHC.Tc.Solver.Interact+addDictCt m cls tys new_ct = alterTcApp m (getUnique cls) tys xt_ct+  where+    new_ct_ev = ctEvidence new_ct++    xt_ct :: Maybe Ct -> Maybe Ct+    xt_ct (Just old_ct)+      | CtWanted { ctev_nosh = WOnly } <- old_ct_ev+      , CtDerived {} <- new_ct_ev+      = Just (old_ct { cc_ev = old_ct_ev { ctev_nosh = WDeriv }})+      | CtDerived {} <- old_ct_ev+      , CtWanted { ctev_nosh = WOnly } <- new_ct_ev+      = Just (new_ct { cc_ev = new_ct_ev { ctev_nosh = WDeriv }})+      where+        old_ct_ev = ctEvidence old_ct++    xt_ct _ = Just new_ct  addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct addDictsByClass m cls items

@@ -1862,7 +1862,8 @@         ; return (poly_meth_id, local_meth_id) }   where     sel_name      = idName sel_id-    sel_occ       = nameOccName sel_name+    -- Force so that a thunk doesn't end up in a Name (#19619)+    !sel_occ      = nameOccName sel_name     local_meth_ty = instantiateMethod clas sel_id inst_tys     poly_meth_ty  = mkSpecSigmaTy tyvars theta local_meth_ty     theta         = map idType dfun_ev_vars

@@ -142,6 +142,7 @@      go_prov (PhantomProv co)     = go_co co      go_prov (ProofIrrelProv co)  = go_co co      go_prov (PluginProv _)       = emptyNameEnv+     go_prov CorePrepProv         = emptyNameEnv       go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc               | otherwise             = emptyNameEnv

@@ -96,7 +96,7 @@ import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.Coercion.Axiom-import GHC.Core.Coercion+ import GHC.Core.Class import GHC.Types.Name import GHC.Types.Name.Set@@ -422,7 +422,7 @@     local_env <- getLclTypeEnv     case lookupNameEnv local_env name of         Just thing -> return thing-        Nothing    -> AGlobal <$> tcLookupGlobal name+        Nothing    -> (AGlobal <$> tcLookupGlobal name)  tcLookupTyVar :: Name -> TcM TcTyVar tcLookupTyVar name@@ -646,8 +646,7 @@            ; wrapper <- case actual_u of                Bottom -> return idHsWrapper                Zero     -> tcSubMult (UsageEnvironmentOf name) Many id_mult-               MUsage m -> do { m <- zonkTcType m-                              ; m <- promote_mult m+               MUsage m -> do { m <- promote_mult m                               ; tcSubMult (UsageEnvironmentOf name) m id_mult }            ; tcEmitBindingUsage (deleteUE uenv name)            ; return wrapper }@@ -673,13 +672,13 @@     -- so we can't use it here. Thus, this dirtiness.     --     -- It works nicely in practice.-    (promote_mult, _, _, _) = mapTyCo mapper-    mapper = TyCoMapper { tcm_tyvar = \ () tv -> do { _ <- promoteTyVar tv-                                                    ; zonkTcTyVar tv }-                        , tcm_covar = \ () cv -> return (mkCoVarCo cv)-                        , tcm_hole  = \ () h  -> return (mkHoleCo h)-                        , tcm_tycobinder = \ () tcv _flag -> return ((), tcv)-                        , tcm_tycon = return }+    --+    -- We use a set to avoid calling promoteMetaTyVarTo twice on the same+    -- metavariable. This happened in #19400.+    promote_mult m = do { fvs <- zonkTyCoVarsAndFV (tyCoVarsOfType m)+                        ; any_promoted <- promoteTyVarSet fvs+                        ; if any_promoted then zonkTcType m else return m+                        }  {- ********************************************************************* *                                                                      *

@@ -592,7 +592,10 @@   = do { loc  <- getSrcSpanM        ; uniq <- newUnique        ; let old_name = tyVarName tycovar-             new_name = mkInternalName uniq (getOccName old_name) loc+             -- Force so we don't retain reference to the old name and id+             -- See (#19619) for more discussion+             !old_occ_name = getOccName old_name+             new_name = mkInternalName uniq old_occ_name loc              new_kind = substTyUnchecked subst (tyVarKind tycovar)              new_tcv  = mk_tcv new_name new_kind              subst1   = extendTCvSubstWithClone subst tycovar new_tcv@@ -850,8 +853,15 @@ tcExtendLocalInstEnv dfuns thing_inside  = do { traceDFuns dfuns       ; env <- getGblEnv+      -- Force the access to the TcgEnv so it isn't retained.+      -- During auditing it is much easier to observe in -hi profiles if+      -- there are a very small number of TcGblEnv. Keeping a TcGblEnv+      -- alive is quite dangerous because it contains reference to many+      -- large data structures.+      ; let !init_inst_env = tcg_inst_env env+            !init_insts = tcg_insts env       ; (inst_env', cls_insts') <- foldlM addLocalInst-                                          (tcg_inst_env env, tcg_insts env)+                                          (init_inst_env, init_insts)                                           dfuns       ; let env' = env { tcg_insts    = cls_insts'                        , tcg_inst_env = inst_env' }

@@ -1514,6 +1514,7 @@     go_prov dv (PhantomProv co)    = go_co dv co     go_prov dv (ProofIrrelProv co) = go_co dv co     go_prov dv (PluginProv _)      = return dv+    go_prov dv CorePrepProv        = return dv      go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs     go_cv dv@(DV { dv_cvs = cvs }) cv

@@ -1731,29 +1731,41 @@     the same as zonkTcTypeToType. (If we distinguished TcType from     Type, this issue would have been a type error!) -Solution: (see #15552 for other variants)+Solutions: (see #15552 for other variants) -    One possible solution is simply not to do the short-circuiting.-    That has less sharing, but maybe sharing is rare. And indeed,-    that turns out to be viable from a perf point of view+One possible solution is simply not to do the short-circuiting.+That has less sharing, but maybe sharing is rare. And indeed,+that usually turns out to be viable from a perf point of view -    But the code implements something a bit better+But zonkTyVarOcc implements something a bit better -    * ZonkEnv contains ze_meta_tv_env, which maps-          from a MetaTyVar (unification variable)-          to a Type (not a TcType)+* ZonkEnv contains ze_meta_tv_env, which maps+      from a MetaTyVar (unification variable)+      to a Type (not a TcType) -    * In zonkTyVarOcc, we check this map to see if we have zonked-      this variable before. If so, use the previous answer; if not-      zonk it, and extend the map.+* In zonkTyVarOcc, we check this map to see if we have zonked+  this variable before. If so, use the previous answer; if not+  zonk it, and extend the map. -    * The map is of course stateful, held in a TcRef. (That is unlike-      the treatment of lexically-scoped variables in ze_tv_env and-      ze_id_env.)+* The map is of course stateful, held in a TcRef. (That is unlike+  the treatment of lexically-scoped variables in ze_tv_env and+  ze_id_env.) -    Is the extra work worth it?  Some non-sytematic perf measurements-    suggest that compiler allocation is reduced overall (by 0.5% or so)-    but compile time really doesn't change.+* In zonkTyVarOcc we read the TcRef to look up the unification+  variable:+    - if we get a hit we use the zonked result;+    - if not, in zonk_meta we see if the variable is `Indirect ty`,+      zonk that, and update the map (in finish_meta)+  But Nota Bene that the "update map" step must re-read the TcRef+  (or, more precisely, use updTcRef) because the zonking of the+  `Indirect ty` may have added lots of stuff to the map.  See+  #19668 for an example where this made an asymptotic difference!++Is it worth the extra work of carrying ze_meta_tv_env? Some+non-systematic perf measurements suggest that compiler allocation is+reduced overall (by 0.5% or so) but compile time really doesn't+change.  But in some cases it makes a HUGE difference: see test+T9198 and #19668.  So yes, it seems worth it. -}  zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType@@ -1770,7 +1782,7 @@               ; case lookupVarEnv mtv_env tv of                   Just ty -> return ty                   Nothing -> do { mtv_details <- readTcRef ref-                                ; zonk_meta mtv_env ref mtv_details } }+                                ; zonk_meta ref mtv_details } }   | otherwise   = lookup_in_tv_env @@ -1780,19 +1792,18 @@           Nothing  -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv           Just tv' -> return (mkTyVarTy tv') -    zonk_meta mtv_env ref Flexi+    zonk_meta ref Flexi       = do { kind <- zonkTcTypeToTypeX env (tyVarKind tv)            ; ty <- commitFlexi flexi tv kind            ; writeMetaTyVarRef tv ref ty  -- Belt and braces-           ; finish_meta mtv_env ty }+           ; finish_meta ty } -    zonk_meta mtv_env _ (Indirect ty)+    zonk_meta _ (Indirect ty)       = do { zty <- zonkTcTypeToTypeX env ty-           ; finish_meta mtv_env zty }+           ; finish_meta zty } -    finish_meta mtv_env ty-      = do { let mtv_env' = extendVarEnv mtv_env tv ty-           ; writeTcRef mtv_env_ref mtv_env'+    finish_meta ty+      = do { updTcRef mtv_env_ref (\env -> extendVarEnv env tv ty)            ; return ty }  lookupTyVarOcc :: ZonkEnv -> TcTyVar -> Maybe TyVar

@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 9.0.1.20210324+version: 9.0.2.20211226 license: BSD3 license-file: LICENSE category: Development@@ -20,7 +20,7 @@ extra-source-files:     ghc-lib/stage0/lib/ghcautoconf.h     ghc-lib/stage0/lib/ghcplatform.h-    ghc-lib/stage0/lib/DerivedConstants.h+    ghc-lib/stage0/lib/GhclibDerivedConstants.h     ghc-lib/stage0/lib/GHCConstantsHaskellExports.hs     ghc-lib/stage0/lib/GHCConstantsHaskellWrappers.hs     ghc-lib/stage0/lib/GHCConstantsHaskellType.hs@@ -40,12 +40,11 @@     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/primop-docs.hs-incl-    includes/ghcconfig.h     includes/MachDeps.h     includes/stg/MachRegs.h     includes/CodeGen.Platform.hs-    compiler/GhclibHsVersions.h     compiler/Unique.h+    compiler/GhclibHsVersions.h source-repository head     type: git     location: git@github.com:digital-asset/ghc-lib.git@@ -66,22 +65,24 @@     else         build-depends: Win32     build-depends:-        ghc-prim > 0.2 && < 0.8,         base >= 4.13 && < 4.16,-        containers >= 0.5 && < 0.7,+        ghc-prim > 0.2 && < 0.8,         bytestring >= 0.9 && < 0.11,+        time >= 1.4 && < 1.10,+        exceptions == 0.10.*,+        parsec,+        containers >= 0.5 && < 0.7,         binary == 0.8.*,         filepath >= 1 && < 1.5,         directory >= 1 && < 1.4,         array >= 0.1 && < 0.6,         deepseq >= 1.4 && < 1.5,         pretty == 1.1.*,-        time >= 1.4 && < 1.10,         transformers == 0.5.*,         process >= 1 && < 1.7,+        rts,         hpc == 0.6.*,-        exceptions == 0.10.*,-        ghc-lib-parser == 9.0.1.20210324+        ghc-lib-parser == 9.0.2.20211226     build-tools: alex >= 3.1, happy >= 1.19.4     other-extensions:         BangPatterns@@ -497,6 +498,7 @@         GHC.Data.Graph.Ops         GHC.Data.Graph.Ppr         GHC.Data.Graph.UnVar+        GHC.Data.UnionFind         GHC.Driver.Backpack         GHC.Driver.CodeOutput         GHC.Driver.Finder@@ -540,7 +542,6 @@         GHC.Iface.Rename         GHC.Iface.Tidy         GHC.Iface.Tidy.StaticPtrTable-        GHC.Iface.UpdateIdInfos         GHC.IfaceToCore         GHC.Llvm         GHC.Llvm.MetaData

@@ -217,7 +217,7 @@   , ("compactSize#"," Return the total capacity (in bytes) of all the compact blocks\n     in the CNF. ")   , ("reallyUnsafePtrEquality#"," Returns @1\\#@ if the given pointers are equal and @0\\#@ otherwise. ")   , ("numSparks#"," Returns the number of sparks in the local spark pool. ")-  , ("keepAlive#"," TODO. ")+  , ("keepAlive#"," \\tt{keepAlive# x s k} keeps the value \\tt{x} alive during the execution\n     of the computation \\tt{k}. ")   , ("BCO"," Primitive bytecode type. ")   , ("addrToAny#"," Convert an @Addr\\#@ to a followable Any type. ")   , ("anyToAddr#"," Retrieve the address of any Haskell value. This is\n     essentially an @unsafeCoerce\\#@, but if implemented as such\n     the core lint pass complains and fails to compile.\n     As a primop, it is opaque to core/stg, and only appears\n     in cmm (where the copy propagation pass will get rid of it).\n     Note that \"a\" must be a value, not a thunk! It's too late\n     for strictness analysis to enforce this, so you're on your\n     own to guarantee this. Also note that @Addr\\#@ is not a GC\n     pointer - up to you to guarantee that it does not become\n     a dangling pointer immediately after you get it.")

@@ -1,555 +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 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 b64-#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 48-#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 52-#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 72-#define SIZEOF_StgCompactNFData (SIZEOF_StgHeader+72)-#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 293-#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 236-#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 231-#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 226-#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 192-#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]

@@ -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 b64+#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 48+#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 52+#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 72+#define SIZEOF_StgCompactNFData (SIZEOF_StgHeader+72)+#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 293+#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 236+#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 231+#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 226+#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 192+#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]

@@ -75,12 +75,7 @@ /* 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'. */+/* Define to 1 if using 'alloca.c'. */ /* #undef C_ALLOCA */  /* Enable Native I/O manager as default. */@@ -93,11 +88,10 @@ /* Has visibility hidden */ #define HAS_VISIBILITY_HIDDEN 1 -/* Define to 1 if you have `alloca', as a function or macro. */+/* 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 to 1 if <alloca.h> works. */ #define HAVE_ALLOCA_H 1  /* Define to 1 if you have the <bfd.h> header file. */@@ -119,6 +113,10 @@    don't. */ #define HAVE_DECL_CTIME_R 1 +/* Define to 1 if you have the declaration of `environ', and to 0 if you+   don't. */+#define HAVE_DECL_ENVIRON 0+ /* Define to 1 if you have the declaration of `MADV_DONTNEED', and to 0 if you    don't. */ /* #undef HAVE_DECL_MADV_DONTNEED */@@ -182,9 +180,6 @@ /* 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 */ @@ -209,12 +204,12 @@ /* 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 <minix/config.h> header file. */+/* #undef HAVE_MINIX_CONFIG_H */+ /* Define to 1 if you have the <nlist.h> header file. */ #define HAVE_NLIST_H 1 @@ -230,9 +225,18 @@ /* Define to 1 if you have the <pthread.h> header file. */ #define HAVE_PTHREAD_H 1 +/* Define to 1 if you have the <pthread_np.h> header file. */+/* #undef HAVE_PTHREAD_NP_H */+ /* 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 Darwin version of pthread_setname_np */+#define HAVE_PTHREAD_SETNAME_NP_DARWIN 1++/* Define to 1 if you have pthread_set_name_np */+/* #undef HAVE_PTHREAD_SET_NAME_NP */+ /* Define to 1 if you have the <pwd.h> header file. */ #define HAVE_PWD_H 1 @@ -260,6 +264,9 @@ /* Define to 1 if you have the <stdint.h> header file. */ #define HAVE_STDINT_H 1 +/* Define to 1 if you have the <stdio.h> header file. */+#define HAVE_STDIO_H 1+ /* Define to 1 if you have the <stdlib.h> header file. */ #define HAVE_STDLIB_H 1 @@ -275,6 +282,9 @@ /* Define to 1 if you have the `sysconf' function. */ #define HAVE_SYSCONF 1 +/* Define to 1 if you have libffi. */+/* #undef HAVE_SYSTEM_LIBFFI */+ /* Define to 1 if you have the <sys/cpuset.h> header file. */ /* #undef HAVE_SYS_CPUSET_H */ @@ -344,6 +354,9 @@ /* Define to 1 if you have the <vfork.h> header file. */ /* #undef HAVE_VFORK_H */ +/* Define to 1 if you have the <wchar.h> header file. */+#define HAVE_WCHAR_H 1+ /* Define to 1 if you have the <windows.h> header file. */ /* #undef HAVE_WINDOWS_H */ @@ -458,13 +471,16 @@ 	STACK_DIRECTION = 0 => direction of growth unknown */ /* #undef STACK_DIRECTION */ -/* Define to 1 if you have the ANSI C header files. */+/* Define to 1 if all of the C90 standard headers exist (not just the ones+   required in a freestanding environment). This macro is provided for+   backward compatibility; new code need not use it. */ #define STDC_HEADERS 1  /* Define to 1 if info tables are laid 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 to 1 if you can safely include both <sys/time.h> and <time.h>. This+   macro is obsolete. */ #define TIME_WITH_SYS_TIME 1  /* Enable single heap address space support */@@ -477,21 +493,87 @@ #ifndef _ALL_SOURCE # define _ALL_SOURCE 1 #endif+/* Enable general extensions on macOS.  */+#ifndef _DARWIN_C_SOURCE+# define _DARWIN_C_SOURCE 1+#endif+/* Enable general extensions on Solaris.  */+#ifndef __EXTENSIONS__+# define __EXTENSIONS__ 1+#endif /* Enable GNU extensions on systems that have them.  */ #ifndef _GNU_SOURCE # define _GNU_SOURCE 1 #endif-/* Enable threading extensions on Solaris.  */+/* Enable X/Open compliant socket functions that do not require linking+   with -lxnet on HP-UX 11.11.  */+#ifndef _HPUX_ALT_XOPEN_SOCKET_API+# define _HPUX_ALT_XOPEN_SOCKET_API 1+#endif+/* Identify the host operating system as Minix.+   This macro does not affect the system headers' behavior.+   A future release of Autoconf may stop defining this macro.  */+#ifndef _MINIX+/* # undef _MINIX */+#endif+/* Enable general extensions on NetBSD.+   Enable NetBSD compatibility extensions on Minix.  */+#ifndef _NETBSD_SOURCE+# define _NETBSD_SOURCE 1+#endif+/* Enable OpenBSD compatibility extensions on NetBSD.+   Oddly enough, this does nothing on OpenBSD.  */+#ifndef _OPENBSD_SOURCE+# define _OPENBSD_SOURCE 1+#endif+/* Define to 1 if needed for POSIX-compatible behavior.  */+#ifndef _POSIX_SOURCE+/* # undef _POSIX_SOURCE */+#endif+/* Define to 2 if needed for POSIX-compatible behavior.  */+#ifndef _POSIX_1_SOURCE+/* # undef _POSIX_1_SOURCE */+#endif+/* Enable POSIX-compatible threading on Solaris.  */ #ifndef _POSIX_PTHREAD_SEMANTICS # define _POSIX_PTHREAD_SEMANTICS 1 #endif+/* Enable extensions specified by ISO/IEC TS 18661-5:2014.  */+#ifndef __STDC_WANT_IEC_60559_ATTRIBS_EXT__+# define __STDC_WANT_IEC_60559_ATTRIBS_EXT__ 1+#endif+/* Enable extensions specified by ISO/IEC TS 18661-1:2014.  */+#ifndef __STDC_WANT_IEC_60559_BFP_EXT__+# define __STDC_WANT_IEC_60559_BFP_EXT__ 1+#endif+/* Enable extensions specified by ISO/IEC TS 18661-2:2015.  */+#ifndef __STDC_WANT_IEC_60559_DFP_EXT__+# define __STDC_WANT_IEC_60559_DFP_EXT__ 1+#endif+/* Enable extensions specified by ISO/IEC TS 18661-4:2015.  */+#ifndef __STDC_WANT_IEC_60559_FUNCS_EXT__+# define __STDC_WANT_IEC_60559_FUNCS_EXT__ 1+#endif+/* Enable extensions specified by ISO/IEC TS 18661-3:2015.  */+#ifndef __STDC_WANT_IEC_60559_TYPES_EXT__+# define __STDC_WANT_IEC_60559_TYPES_EXT__ 1+#endif+/* Enable extensions specified by ISO/IEC TR 24731-2:2010.  */+#ifndef __STDC_WANT_LIB_EXT2__+# define __STDC_WANT_LIB_EXT2__ 1+#endif+/* Enable extensions specified by ISO/IEC 24747:2009.  */+#ifndef __STDC_WANT_MATH_SPEC_FUNCS__+# define __STDC_WANT_MATH_SPEC_FUNCS__ 1+#endif /* Enable extensions on HP NonStop.  */ #ifndef _TANDEM_SOURCE # define _TANDEM_SOURCE 1 #endif-/* Enable general extensions on Solaris.  */-#ifndef __EXTENSIONS__-# define __EXTENSIONS__ 1+/* Enable X/Open extensions.  Define to 500 only if necessary+   to make mbstate_t available.  */+#ifndef _XOPEN_SOURCE+/* # undef _XOPEN_SOURCE */ #endif  @@ -510,27 +592,12 @@ # 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 */ @@ -540,11 +607,14 @@ /* Define to empty if `const' does not conform to ANSI C. */ /* #undef const */ -/* Define to `int' if <sys/types.h> does not define. */+/* Define as a signed integer type capable of holding a process identifier. */ /* #undef pid_t */ -/* The supported LLVM version number */-#define sUPPORTED_LLVM_VERSION (9)+/* The maximum supported LLVM version number */+#define sUPPORTED_LLVM_VERSION_MAX (13)++/* The minimum supported LLVM version number */+#define sUPPORTED_LLVM_VERSION_MIN (9)  /* Define to `unsigned int' if <sys/types.h> does not define. */ /* #undef size_t */

@@ -40,7 +40,7 @@ ,("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-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:128-n8:16:32-S128", "penryn", "")) ,("x86_64-apple-darwin", ("e-m:o-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "penryn", ""))-,("arm64-apple-darwin", ("e-m:o-i64:64-i128:128-n32:64-S128", "vortex", "+v8.3a +fp-armv8 +neon +crc +crypto +fullfp16 +ras +lse +rdm +rcpc +zcm +zcz +sha2 +aes"))+,("arm64-apple-darwin", ("e-m:o-i64:64-i128:128-n32:64-S128", "apple-a12", "+v8.3a +fp-armv8 +neon +crc +crypto +fullfp16 +ras +lse +rdm +rcpc +zcm +zcz +sha2 +aes")) ,("armv7-apple-ios", ("e-m:o-p:32:32-Fi8-f64:32:64-v64:32:64-v128:32:128-a:0:32-n32-S32", "generic", "")) ,("aarch64-apple-ios", ("e-m:o-i64:64-i128:128-n32:64-S128", "apple-a7", "+fp-armv8 +neon +crypto +zcm +zcz +sha2 +aes")) ,("i386-apple-ios", ("e-m:o-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:128-n8:16:32-S128", "yonah", ""))

@@ -1,8 +1,8 @@ [("GCC extra via C opts", "") ,("C compiler command", "cc")-,("C compiler flags", "")-,("C++ compiler flags", "")-,("C compiler link flags", "")+,("C compiler flags", "--target=x86_64-apple-darwin ")+,("C++ compiler flags", "--target=x86_64-apple-darwin ")+,("C compiler link flags", "--target=x86_64-apple-darwin  ") ,("C compiler supports -no-pie", "NO") ,("Haskell CPP command", "cc") ,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs")

@@ -1,4 +0,0 @@-#pragma once--#include "ghcautoconf.h"-#include "ghcplatform.h"

@@ -35,8 +35,8 @@    -> Int     -- pointer tag    -> ByteString  -- con desc    -> IO (Ptr StgInfoTable)-      -- resulting info table is allocated with allocateExec(), and-      -- should be freed with freeExec().+      -- resulting info table is allocated with allocateExecPage(), and+      -- should be freed with freeExecPage().  mkConInfoTable tables_next_to_code ptr_words nonptr_words tag ptrtag con_desc = do   let entry_addr = interpConstrEntry !! ptrtag@@ -358,19 +358,18 @@  -- Note: Must return proper pointer for use in a closure newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ())-newExecConItbl tables_next_to_code obj con_desc-   = alloca $ \pcode -> do-        sz0 <- sizeOfEntryCode tables_next_to_code-        let lcon_desc = BS.length con_desc + 1{- null terminator -}-            -- SCARY-            -- This size represents the number of bytes in an StgConInfoTable.-            sz = fromIntegral $ conInfoTableSizeB + sz0-               -- Note: we need to allocate the conDesc string next to the info-               -- table, because on a 64-bit platform we reference this string-               -- with a 32-bit offset relative to the info table, so if we-               -- allocated the string separately it might be out of range.-        wr_ptr <- _allocateExec (sz + fromIntegral lcon_desc) pcode-        ex_ptr <- peek pcode+newExecConItbl tables_next_to_code obj con_desc = do+    sz0 <- sizeOfEntryCode tables_next_to_code+    let lcon_desc = BS.length con_desc + 1{- null terminator -}+        -- SCARY+        -- This size represents the number of bytes in an StgConInfoTable.+        sz = fromIntegral $ conInfoTableSizeB + sz0+            -- Note: we need to allocate the conDesc string next to the info+            -- table, because on a 64-bit platform we reference this string+            -- with a 32-bit offset relative to the info table, so if we+            -- allocated the string separately it might be out of range.++    ex_ptr <- fillExecBuffer (sz + fromIntegral lcon_desc) $ \wr_ptr ex_ptr -> do         let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz                                     , infoTable = obj }         pokeConItbl tables_next_to_code wr_ptr ex_ptr cinfo@@ -378,16 +377,52 @@             copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len         let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)         poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)-        _flushExec sz ex_ptr -- Cache flush (if needed)-        pure $ if tables_next_to_code-          then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB-          else castPtrToFunPtr ex_ptr +    pure $ if tables_next_to_code+      then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB+      else castPtrToFunPtr ex_ptr++-- | Allocate a buffer of a given size, use the given action to fill it with+-- data, and mark it as executable. The action is given a writable pointer and+-- the executable pointer. Returns a pointer to the executable code.+fillExecBuffer :: CSize -> (Ptr a -> Ptr a -> IO ()) -> IO (Ptr a)++#if MIN_VERSION_rts(1,0,2)++data ExecPage++foreign import ccall unsafe "allocateExecPage"+  _allocateExecPage :: IO (Ptr ExecPage)++foreign import ccall unsafe "freezeExecPage"+  _freezeExecPage :: Ptr ExecPage -> IO ()++fillExecBuffer sz cont+    -- we can only allocate single pages. This assumes a 4k page size which+    -- isn't strictly correct but is a reasonable conservative lower bound.+  | sz > 4096 = fail "withExecBuffer: Too large"+  | otherwise = do+        pg <- _allocateExecPage+        cont (castPtr pg) (castPtr pg)+        _freezeExecPage pg+        return (castPtr pg)++#else+ foreign import ccall unsafe "allocateExec"   _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)  foreign import ccall unsafe "flushExec"   _flushExec :: CUInt -> Ptr a -> IO ()++fillExecBuffer sz cont = alloca $ \pcode -> do+    wr_ptr <- _allocateExec (fromIntegral sz) pcode+    ex_ptr <- peek pcode+    cont wr_ptr ex_ptr+    _flushExec (fromIntegral sz) ex_ptr -- Cache flush (if needed)+    return (ex_ptr)++#endif  -- ----------------------------------------------------------------------------- -- Constants and config