diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs --- a/compiler/GHC/Cmm/Utils.hs +++ b/compiler/GHC/Cmm/Utils.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/BlockLayout.hs b/compiler/GHC/CmmToAsm/BlockLayout.hs --- a/compiler/GHC/CmmToAsm/BlockLayout.hs +++ b/compiler/GHC/CmmToAsm/BlockLayout.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/CFG.hs b/compiler/GHC/CmmToAsm/CFG.hs --- a/compiler/GHC/CmmToAsm/CFG.hs +++ b/compiler/GHC/CmmToAsm/CFG.hs @@ -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)] diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs --- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs @@ -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` diff --git a/compiler/GHC/CmmToAsm/Reg/Linear.hs b/compiler/GHC/CmmToAsm/Reg/Linear.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs b/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs @@ -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 diff --git a/compiler/GHC/CmmToLlvm.hs b/compiler/GHC/CmmToLlvm.hs --- a/compiler/GHC/CmmToLlvm.hs +++ b/compiler/GHC/CmmToLlvm.hs @@ -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 diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs --- a/compiler/GHC/CmmToLlvm/Base.hs +++ b/compiler/GHC/CmmToLlvm/Base.hs @@ -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 diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -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] ~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -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 diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -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] diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs --- a/compiler/GHC/CoreToByteCode.hs +++ b/compiler/GHC/CoreToByteCode.hs @@ -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) diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -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)) diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -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 + diff --git a/compiler/GHC/Data/UnionFind.hs b/compiler/GHC/Data/UnionFind.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Data/UnionFind.hs @@ -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) + diff --git a/compiler/GHC/Driver/Finder.hs b/compiler/GHC/Driver/Finder.hs --- a/compiler/GHC/Driver/Finder.hs +++ b/compiler/GHC/Driver/Finder.hs @@ -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 diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -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 } diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -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 diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -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 diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -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 diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -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 diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -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 diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs --- a/compiler/GHC/HsToCore/Usage.hs +++ b/compiler/GHC/HsToCore/Usage.hs @@ -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] diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -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" diff --git a/compiler/GHC/Iface/Recomp/Flags.hs b/compiler/GHC/Iface/Recomp/Flags.hs --- a/compiler/GHC/Iface/Recomp/Flags.hs +++ b/compiler/GHC/Iface/Recomp/Flags.hs @@ -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) diff --git a/compiler/GHC/Iface/UpdateIdInfos.hs b/compiler/GHC/Iface/UpdateIdInfos.hs deleted file mode 100644 --- a/compiler/GHC/Iface/UpdateIdInfos.hs +++ /dev/null @@ -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 diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -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 diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -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 _) diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -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 ---------------------------- diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -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]) diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs --- a/compiler/GHC/Runtime/Linker.hs +++ b/compiler/GHC/Runtime/Linker.hs @@ -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" diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs --- a/compiler/GHC/Stg/Unarise.hs +++ b/compiler/GHC/Stg/Unarise.hs @@ -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) diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs --- a/compiler/GHC/StgToCmm/Prof.hs +++ b/compiler/GHC/StgToCmm/Prof.hs @@ -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) diff --git a/compiler/GHC/SysTools.hs b/compiler/GHC/SysTools.hs --- a/compiler/GHC/SysTools.hs +++ b/compiler/GHC/SysTools.hs @@ -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 ] diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs --- a/compiler/GHC/SysTools/Tasks.hs +++ b/compiler/GHC/SysTools/Tasks.hs @@ -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 diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -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 diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs --- a/compiler/GHC/Tc/Errors/Hole.hs +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -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. diff --git a/compiler/GHC/Tc/Errors/Hole.hs-boot b/compiler/GHC/Tc/Errors/Hole.hs-boot --- a/compiler/GHC/Tc/Errors/Hole.hs-boot +++ b/compiler/GHC/Tc/Errors/Hole.hs-boot @@ -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] diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -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 diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -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' } {- ************************************************************************ diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -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 | | 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 diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs --- a/compiler/GHC/Tc/Solver/Interact.hs +++ b/compiler/GHC/Tc/Solver/Interact.hs @@ -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) diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -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 diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -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 diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -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 diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -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 + } {- ********************************************************************* * * diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -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' } diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -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 diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -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 diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -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 diff --git a/ghc-lib/stage0/compiler/build/primop-docs.hs-incl b/ghc-lib/stage0/compiler/build/primop-docs.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-docs.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-docs.hs-incl @@ -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.") diff --git a/ghc-lib/stage0/lib/DerivedConstants.h b/ghc-lib/stage0/lib/DerivedConstants.h deleted file mode 100644 --- a/ghc-lib/stage0/lib/DerivedConstants.h +++ /dev/null @@ -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] diff --git a/ghc-lib/stage0/lib/GhclibDerivedConstants.h b/ghc-lib/stage0/lib/GhclibDerivedConstants.h new file mode 100644 --- /dev/null +++ b/ghc-lib/stage0/lib/GhclibDerivedConstants.h @@ -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] diff --git a/ghc-lib/stage0/lib/ghcautoconf.h b/ghc-lib/stage0/lib/ghcautoconf.h --- a/ghc-lib/stage0/lib/ghcautoconf.h +++ b/ghc-lib/stage0/lib/ghcautoconf.h @@ -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 and it should be used (not on Ultrix). - */ +/* Define to 1 if works. */ #define HAVE_ALLOCA_H 1 /* Define to 1 if you have the 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 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 header file. */ +/* #undef HAVE_MINIX_CONFIG_H */ + /* Define to 1 if you have the header file. */ #define HAVE_NLIST_H 1 @@ -230,9 +225,18 @@ /* Define to 1 if you have the header file. */ #define HAVE_PTHREAD_H 1 +/* Define to 1 if you have the 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 header file. */ #define HAVE_PWD_H 1 @@ -260,6 +264,9 @@ /* Define to 1 if you have the header file. */ #define HAVE_STDINT_H 1 +/* Define to 1 if you have the header file. */ +#define HAVE_STDIO_H 1 + /* Define to 1 if you have the 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 header file. */ /* #undef HAVE_SYS_CPUSET_H */ @@ -344,6 +354,9 @@ /* Define to 1 if you have the header file. */ /* #undef HAVE_VFORK_H */ +/* Define to 1 if you have the header file. */ +#define HAVE_WCHAR_H 1 + /* Define to 1 if you have the 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 and . */ +/* Define to 1 if you can safely include both and . 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 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 does not define. */ /* #undef size_t */ diff --git a/ghc-lib/stage0/lib/llvm-targets b/ghc-lib/stage0/lib/llvm-targets --- a/ghc-lib/stage0/lib/llvm-targets +++ b/ghc-lib/stage0/lib/llvm-targets @@ -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", "")) diff --git a/ghc-lib/stage0/lib/settings b/ghc-lib/stage0/lib/settings --- a/ghc-lib/stage0/lib/settings +++ b/ghc-lib/stage0/lib/settings @@ -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") diff --git a/includes/ghcconfig.h b/includes/ghcconfig.h deleted file mode 100644 --- a/includes/ghcconfig.h +++ /dev/null @@ -1,4 +0,0 @@ -#pragma once - -#include "ghcautoconf.h" -#include "ghcplatform.h" diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc --- a/libraries/ghci/GHCi/InfoTable.hsc +++ b/libraries/ghci/GHCi/InfoTable.hsc @@ -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