diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs --- a/compiler/GHC/ByteCode/Asm.hs +++ b/compiler/GHC/ByteCode/Asm.hs @@ -27,7 +27,6 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Literal -import GHC.Types.Unique import GHC.Types.Unique.DSet import GHC.Utils.Outputable @@ -518,11 +517,11 @@ CCALL off m_addr i -> do np <- addr m_addr emit bci_CCALL [wOp off, Op np, SmallOp i] PRIMCALL -> emit bci_PRIMCALL [] - BRK_FUN index uniq cc -> do p1 <- ptr BCOPtrBreakArray - q <- int (getKey uniq) + BRK_FUN index mod cc -> do p1 <- ptr BCOPtrBreakArray + m <- addr mod np <- addr cc emit bci_BRK_FUN [Op p1, SmallOp index, - Op q, Op np] + Op m, Op np] where literal (LitLabel fs (Just sz) _) diff --git a/compiler/GHC/ByteCode/Instr.hs b/compiler/GHC/ByteCode/Instr.hs --- a/compiler/GHC/ByteCode/Instr.hs +++ b/compiler/GHC/ByteCode/Instr.hs @@ -19,7 +19,6 @@ import GHC.StgToCmm.Layout ( ArgRep(..) ) import GHC.Utils.Outputable import GHC.Types.Name -import GHC.Types.Unique import GHC.Types.Literal import GHC.Core.DataCon import GHC.Builtin.PrimOps @@ -31,6 +30,7 @@ import GHC.Stack.CCS (CostCentre) import GHC.Stg.Syntax +import Language.Haskell.Syntax.Module.Name (ModuleName) -- ---------------------------------------------------------------------------- -- Bytecode instructions @@ -205,7 +205,7 @@ -- Note [unboxed tuple bytecodes and tuple_BCO] in GHC.StgToByteCode -- Breakpoints - | BRK_FUN !Word16 Unique (RemotePtr CostCentre) + | BRK_FUN !Word16 (RemotePtr ModuleName) (RemotePtr CostCentre) -- ----------------------------------------------------------------------------- -- Printing bytecode instructions @@ -356,11 +356,7 @@ ppr ENTER = text "ENTER" ppr (RETURN pk) = text "RETURN " <+> ppr pk ppr (RETURN_TUPLE) = text "RETURN_TUPLE" - ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> mb_uniq <+> text "" - where mb_uniq = sdocOption sdocSuppressUniques $ \case - True -> text "" - False -> ppr uniq - + ppr (BRK_FUN index _mod_name _cc) = text "BRK_FUN" <+> ppr index <+> text "" <+> text "" -- ----------------------------------------------------------------------------- diff --git a/compiler/GHC/Cmm/CommonBlockElim.hs b/compiler/GHC/Cmm/CommonBlockElim.hs --- a/compiler/GHC/Cmm/CommonBlockElim.hs +++ b/compiler/GHC/Cmm/CommonBlockElim.hs @@ -26,6 +26,7 @@ import qualified GHC.Data.TrieMap as TM import GHC.Types.Unique.FM import GHC.Types.Unique +import GHC.Utils.Word64 (truncateWord64ToWord32) import Control.Arrow (first, second) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE @@ -182,8 +183,10 @@ cvt = fromInteger . toInteger + -- Since we are hashing, we can savely downcast Word64 to Word32 here. + -- Although a different hashing function may be more effective. hash_unique :: Uniquable a => a -> Word32 - hash_unique = cvt . getKey . getUnique + hash_unique = truncateWord64ToWord32 . getKey . getUnique -- | Ignore these node types for equality dont_care :: CmmNode O x -> Bool diff --git a/compiler/GHC/Cmm/Dominators.hs b/compiler/GHC/Cmm/Dominators.hs --- a/compiler/GHC/Cmm/Dominators.hs +++ b/compiler/GHC/Cmm/Dominators.hs @@ -26,8 +26,7 @@ import Data.Foldable() import qualified Data.Tree as Tree -import qualified Data.IntMap.Strict as IM -import qualified Data.IntSet as IS +import Data.Word import qualified GHC.CmmToAsm.CFG.Dominators as LT @@ -41,6 +40,9 @@ import GHC.Utils.Outputable( Outputable(..), text, int, hcat, (<+>)) import GHC.Utils.Misc import GHC.Utils.Panic +import GHC.Utils.Word64 (intToWord64) +import qualified GHC.Data.Word64Map as WM +import qualified GHC.Data.Word64Set as WS -- | =Dominator sets @@ -129,33 +131,37 @@ -- The implementation uses the Lengauer-Tarjan algorithm from the x86 -- back end. +-- Technically, we do not need Word64 here, however the dominators code +-- has to accomodate Word64 for other uses. + graphWithDominators g = GraphWithDominators (reachable rpblocks g) dmap rpmap where rpblocks = revPostorderFrom (graphMap g) (g_entry g) rplabels' = map entryLabel rpblocks - rplabels :: Array Int Label + rplabels :: Array Word64 Label rplabels = listArray bounds rplabels' rpmap :: LabelMap RPNum rpmap = mapFromList $ zipWith kvpair rpblocks [0..] where kvpair block i = (entryLabel block, RPNum i) - labelIndex :: Label -> Int + labelIndex :: Label -> Word64 labelIndex = flip findLabelIn imap - where imap :: LabelMap Int + where imap :: LabelMap Word64 imap = mapFromList $ zip rplabels' [0..] blockIndex = labelIndex . entryLabel - bounds = (0, length rpblocks - 1) + bounds :: (Word64, Word64) + bounds = (0, intToWord64 (length rpblocks - 1)) ltGraph :: [Block node C C] -> LT.Graph - ltGraph [] = IM.empty + ltGraph [] = WM.empty ltGraph (block:blocks) = - IM.insert + WM.insert (blockIndex block) - (IS.fromList $ map labelIndex $ successors block) + (WS.fromList $ map labelIndex $ successors block) (ltGraph blocks) - idom_array :: Array Int LT.Node + idom_array :: Array Word64 LT.Node idom_array = array bounds $ LT.idom (0, ltGraph rpblocks) domSet 0 = EntryNode diff --git a/compiler/GHC/Cmm/LRegSet.hs b/compiler/GHC/Cmm/LRegSet.hs --- a/compiler/GHC/Cmm/LRegSet.hs +++ b/compiler/GHC/Cmm/LRegSet.hs @@ -20,34 +20,35 @@ import GHC.Prelude import GHC.Types.Unique import GHC.Cmm.Expr +import GHC.Word -import Data.IntSet as IntSet +import GHC.Data.Word64Set as Word64Set -- Compact sets for membership tests of local variables. -type LRegSet = IntSet.IntSet -type LRegKey = Int +type LRegSet = Word64Set.Word64Set +type LRegKey = Word64 emptyLRegSet :: LRegSet -emptyLRegSet = IntSet.empty +emptyLRegSet = Word64Set.empty nullLRegSet :: LRegSet -> Bool -nullLRegSet = IntSet.null +nullLRegSet = Word64Set.null insertLRegSet :: LocalReg -> LRegSet -> LRegSet -insertLRegSet l = IntSet.insert (getKey (getUnique l)) +insertLRegSet l = Word64Set.insert (getKey (getUnique l)) elemLRegSet :: LocalReg -> LRegSet -> Bool -elemLRegSet l = IntSet.member (getKey (getUnique l)) +elemLRegSet l = Word64Set.member (getKey (getUnique l)) deleteFromLRegSet :: LRegSet -> LocalReg -> LRegSet -deleteFromLRegSet set reg = IntSet.delete (getKey . getUnique $ reg) set +deleteFromLRegSet set reg = Word64Set.delete (getKey . getUnique $ reg) set -sizeLRegSet :: IntSet -> Int -sizeLRegSet = IntSet.size +sizeLRegSet :: Word64Set -> Int +sizeLRegSet = Word64Set.size -plusLRegSet :: IntSet -> IntSet -> IntSet -plusLRegSet = IntSet.union +plusLRegSet :: Word64Set -> Word64Set -> Word64Set +plusLRegSet = Word64Set.union -elemsLRegSet :: IntSet -> [Int] -elemsLRegSet = IntSet.toList +elemsLRegSet :: Word64Set -> [Word64] +elemsLRegSet = Word64Set.toList diff --git a/compiler/GHC/Cmm/Sink.hs b/compiler/GHC/Cmm/Sink.hs --- a/compiler/GHC/Cmm/Sink.hs +++ b/compiler/GHC/Cmm/Sink.hs @@ -21,7 +21,7 @@ import GHC.Platform import GHC.Types.Unique.FM -import qualified Data.IntSet as IntSet +import qualified GHC.Data.Word64Set as Word64Set import Data.List (partition) import Data.Maybe @@ -175,7 +175,7 @@ -- Annotate the middle nodes with the registers live *after* -- the node. This will help us decide whether we can inline -- an assignment in the current node or not. - live = IntSet.unions (map getLive succs) + live = Word64Set.unions (map getLive succs) live_middle = gen_killL platform last live ann_middles = annotate platform live_middle (blockToList middle) @@ -188,7 +188,7 @@ -- one predecessor), so identify the join points and the set -- of registers live in them. (joins, nonjoins) = partition (`mapMember` join_pts) succs - live_in_joins = IntSet.unions (map getLive joins) + live_in_joins = Word64Set.unions (map getLive joins) -- We do not want to sink an assignment into multiple branches, -- so identify the set of registers live in multiple successors. @@ -215,7 +215,7 @@ live_sets' | should_drop = live_sets | otherwise = map upd live_sets - upd set | r `elemLRegSet` set = set `IntSet.union` live_rhs + upd set | r `elemLRegSet` set = set `Word64Set.union` live_rhs | otherwise = set live_rhs = foldRegsUsed platform (flip insertLRegSet) emptyLRegSet rhs 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 @@ -60,12 +60,16 @@ import GHC.Types.Unique import qualified GHC.CmmToAsm.CFG.Dominators as Dom import GHC.CmmToAsm.CFG.Weight +import GHC.Data.Word64Map.Strict (Word64Map) +import GHC.Data.Word64Set (Word64Set) import Data.IntMap.Strict (IntMap) import Data.IntSet (IntSet) import qualified Data.IntMap.Strict as IM +import qualified GHC.Data.Word64Map.Strict as WM import qualified Data.Map as M import qualified Data.IntSet as IS +import qualified GHC.Data.Word64Set as WS import qualified Data.Set as S import Data.Tree import Data.Bifunctor @@ -90,6 +94,7 @@ import Control.Monad import GHC.Data.UnionFind +import Data.Word type Prob = Double @@ -851,7 +856,7 @@ --TODO - This should be a no op: Export constructors? Use unsafeCoerce? ... rooted = ( fromBlockId root - , toIntMap $ fmap toIntSet graph) :: (Int, IntMap IntSet) + , toWord64Map $ fmap toWord64Set graph) :: (Word64, Word64Map Word64Set) tree = fmap toBlockId $ Dom.domTree rooted :: Tree BlockId -- Map from Nodes to their dominators @@ -898,10 +903,10 @@ loopCount n = length $ nub . map fst . filter (setMember n . snd) $ bodies in map (\n -> (n, loopCount n)) $ nodes :: [(BlockId, Int)] - toIntSet :: LabelSet -> IntSet - toIntSet s = IS.fromList . map fromBlockId . setElems $ s - toIntMap :: LabelMap a -> IntMap a - toIntMap m = IM.fromList $ map (\(x,y) -> (fromBlockId x,y)) $ mapToList m + toWord64Set :: LabelSet -> Word64Set + toWord64Set s = WS.fromList . map fromBlockId . setElems $ s + toWord64Map :: LabelMap a -> Word64Map a + toWord64Map m = WM.fromList $ map (\(x,y) -> (fromBlockId x,y)) $ mapToList m mkDomMap :: Tree BlockId -> LabelMap LabelSet mkDomMap root = mapFromList $ go setEmpty root @@ -916,10 +921,10 @@ (\n -> go (setInsert (rootLabel n) parents) n) leaves - fromBlockId :: BlockId -> Int + fromBlockId :: BlockId -> Word64 fromBlockId = getKey . getUnique - toBlockId :: Int -> BlockId + toBlockId :: Word64 -> BlockId toBlockId = mkBlockId . mkUniqueGrimily -- We make the CFG a Hoopl Graph, so we can reuse revPostOrder. diff --git a/compiler/GHC/CmmToAsm/CFG/Dominators.hs b/compiler/GHC/CmmToAsm/CFG/Dominators.hs --- a/compiler/GHC/CmmToAsm/CFG/Dominators.hs +++ b/compiler/GHC/CmmToAsm/CFG/Dominators.hs @@ -21,8 +21,8 @@ /Advanced Compiler Design and Implementation/, 1997. \[3\] Brisk, Sarrafzadeh, - /Interference Graphs for Procedures in Static Single/ - /Information Form are Interval Graphs/, 2007. + /Interference CGraphs for Procedures in Static Single/ + /Information Form are Interval CGraphs/, 2007. * Strictness @@ -40,7 +40,7 @@ ,pddfs,rpddfs ,fromAdj,fromEdges ,toAdj,toEdges - ,asTree,asGraph + ,asTree,asCGraph ,parents,ancestors ) where @@ -61,15 +61,24 @@ import Data.Array.Base (unsafeNewArray_ ,unsafeWrite,unsafeRead) +import GHC.Data.Word64Set (Word64Set) +import qualified GHC.Data.Word64Set as WS +import GHC.Data.Word64Map (Word64Map) +import qualified GHC.Data.Word64Map as WM +import Data.Word ----------------------------------------------------------------------------- -type Node = Int -type Path = [Node] -type Edge = (Node,Node) -type Graph = IntMap IntSet -type Rooted = (Node, Graph) +-- Compacted nodes; these can be stored in contiguous arrays +type CNode = Int +type CGraph = IntMap IntSet +type Node = Word64 +type Path = [Node] +type Edge = (Node, Node) +type Graph = Word64Map Word64Set +type Rooted = (Node, Graph) + ----------------------------------------------------------------------------- -- | /Dominators/. @@ -111,7 +120,7 @@ -- | /Immediate post-dominators/. -- Complexity as for @idom@. ipdom :: Rooted -> [(Node,Node)] -ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predG rg))) +ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predGW rg))) ----------------------------------------------------------------------------- @@ -126,24 +135,24 @@ ----------------------------------------------------------------------------- type Dom s a = S s (Env s) a -type NodeSet = IntSet -type NodeMap a = IntMap a +type NodeSet = Word64Set +type NodeMap a = Word64Map a data Env s = Env - {succE :: !Graph - ,predE :: !Graph - ,bucketE :: !Graph + {succE :: !CGraph + ,predE :: !CGraph + ,bucketE :: !CGraph ,dfsE :: {-# UNPACK #-}!Int - ,zeroE :: {-# UNPACK #-}!Node - ,rootE :: {-# UNPACK #-}!Node - ,labelE :: {-# UNPACK #-}!(Arr s Node) - ,parentE :: {-# UNPACK #-}!(Arr s Node) - ,ancestorE :: {-# UNPACK #-}!(Arr s Node) - ,childE :: {-# UNPACK #-}!(Arr s Node) - ,ndfsE :: {-# UNPACK #-}!(Arr s Node) + ,zeroE :: {-# UNPACK #-}!CNode + ,rootE :: {-# UNPACK #-}!CNode + ,labelE :: {-# UNPACK #-}!(Arr s CNode) + ,parentE :: {-# UNPACK #-}!(Arr s CNode) + ,ancestorE :: {-# UNPACK #-}!(Arr s CNode) + ,childE :: {-# UNPACK #-}!(Arr s CNode) + ,ndfsE :: {-# UNPACK #-}!(Arr s CNode) ,dfnE :: {-# UNPACK #-}!(Arr s Int) ,sdnoE :: {-# UNPACK #-}!(Arr s Int) ,sizeE :: {-# UNPACK #-}!(Arr s Int) - ,domE :: {-# UNPACK #-}!(Arr s Node) + ,domE :: {-# UNPACK #-}!(Arr s CNode) ,rnE :: {-# UNPACK #-}!(Arr s Node)} ----------------------------------------------------------------------------- @@ -188,7 +197,7 @@ ----------------------------------------------------------------------------- -eval :: Node -> Dom s Node +eval :: CNode -> Dom s CNode eval v = do n0 <- zeroM a <- ancestorM v @@ -205,7 +214,7 @@ True-> return l False-> return la -compress :: Node -> Dom s () +compress :: CNode -> Dom s () compress v = do n0 <- zeroM a <- ancestorM v @@ -224,7 +233,7 @@ ----------------------------------------------------------------------------- -link :: Node -> Node -> Dom s () +link :: CNode -> CNode -> Dom s () link v w = do n0 <- zeroM lw <- labelM w @@ -268,7 +277,7 @@ ----------------------------------------------------------------------------- -dfsDom :: Node -> Dom s () +dfsDom :: CNode -> Dom s () dfsDom i = do _ <- go i n0 <- zeroM @@ -293,10 +302,10 @@ initEnv :: Rooted -> ST s (Env s) initEnv (r0,g0) = do - -- Graph renumbered to indices from 1 to |V| + -- CGraph renumbered to indices from 1 to |V| let (g,rnmap) = renum 1 g0 pred = predG g -- reverse graph - root = rnmap IM.! r0 -- renamed root + root = rnmap WM.! r0 -- renamed root n = IM.size g ns = [0..n] m = n+1 @@ -304,9 +313,9 @@ let bucket = IM.fromList (zip ns (repeat mempty)) - rna <- newI m + rna <- newW m writes rna (fmap swap - (IM.toList rnmap)) + (WM.toList rnmap)) doms <- newI m sdno <- newI m @@ -361,33 +370,33 @@ ----------------------------------------------------------------------------- -zeroM :: Dom s Node +zeroM :: Dom s CNode zeroM = gets zeroE -domM :: Node -> Dom s Node +domM :: CNode -> Dom s CNode domM = fetch domE -rootM :: Dom s Node +rootM :: Dom s CNode rootM = gets rootE -succsM :: Node -> Dom s [Node] +succsM :: CNode -> Dom s [CNode] succsM i = gets (IS.toList . (! i) . succE) -predsM :: Node -> Dom s [Node] +predsM :: CNode -> Dom s [CNode] predsM i = gets (IS.toList . (! i) . predE) -bucketM :: Node -> Dom s [Node] +bucketM :: CNode -> Dom s [CNode] bucketM i = gets (IS.toList . (! i) . bucketE) -sizeM :: Node -> Dom s Int +sizeM :: CNode -> Dom s Int sizeM = fetch sizeE -sdnoM :: Node -> Dom s Int +sdnoM :: CNode -> Dom s Int sdnoM = fetch sdnoE --- dfnM :: Node -> Dom s Int +-- dfnM :: CNode -> Dom s Int -- dfnM = fetch dfnE -ndfsM :: Int -> Dom s Node +ndfsM :: Int -> Dom s CNode ndfsM = fetch ndfsE -childM :: Node -> Dom s Node +childM :: CNode -> Dom s CNode childM = fetch childE -ancestorM :: Node -> Dom s Node +ancestorM :: CNode -> Dom s CNode ancestorM = fetch ancestorE -parentM :: Node -> Dom s Node +parentM :: CNode -> Dom s CNode parentM = fetch parentE -labelM :: Node -> Dom s Node +labelM :: CNode -> Dom s CNode labelM = fetch labelE nextM :: Dom s Int nextM = do @@ -422,6 +431,9 @@ newI :: Int -> ST s (Arr s Int) newI = new +newW :: Int -> ST s (Arr s Node) +newW = new + writes :: (MArray (A s) a (ST s)) => Arr s a -> [(Int,a)] -> ST s () writes a xs = forM_ xs (\(i,x) -> (a.=x) i) @@ -431,18 +443,18 @@ (!) g n = maybe mempty id (IM.lookup n g) fromAdj :: [(Node, [Node])] -> Graph -fromAdj = IM.fromList . fmap (second IS.fromList) +fromAdj = WM.fromList . fmap (second WS.fromList) fromEdges :: [Edge] -> Graph -fromEdges = collectI IS.union fst (IS.singleton . snd) +fromEdges = collectW WS.union fst (WS.singleton . snd) toAdj :: Graph -> [(Node, [Node])] -toAdj = fmap (second IS.toList) . IM.toList +toAdj = fmap (second WS.toList) . WM.toList toEdges :: Graph -> [Edge] toEdges = concatMap (uncurry (fmap . (,))) . toAdj -predG :: Graph -> Graph +predG :: CGraph -> CGraph predG g = IM.unionWith IS.union (go g) g0 where g0 = fmap (const mempty) g go = flip IM.foldrWithKey mempty (\i a m -> @@ -451,15 +463,24 @@ m (IS.toList a)) +predGW :: Graph -> Graph +predGW g = WM.unionWith WS.union (go g) g0 + where g0 = fmap (const mempty) g + go = flip WM.foldrWithKey mempty (\i a m -> + foldl' (\m p -> WM.insertWith mappend p + (WS.singleton i) m) + m + (WS.toList a)) + pruneReach :: Rooted -> Rooted pruneReach (r,g) = (r,g2) where is = reachable (maybe mempty id - . flip IM.lookup g) $ r - g2 = IM.fromList - . fmap (second (IS.filter (`IS.member`is))) - . filter ((`IS.member`is) . fst) - . IM.toList $ g + . flip WM.lookup g) $ r + g2 = WM.fromList + . fmap (second (WS.filter (`WS.member`is))) + . filter ((`WS.member`is) . fst) + . WM.toList $ g tip :: Tree a -> (a, [Tree a]) tip (Node a ts) = (a, ts) @@ -476,26 +497,28 @@ in p acc' xs ++ concatMap (go acc') xs p is = fmap (flip (,) is . rootLabel) -asGraph :: Tree Node -> Rooted -asGraph t@(Node a _) = let g = go t in (a, fromAdj g) +asCGraph :: Tree Node -> Rooted +asCGraph t@(Node a _) = let g = go t in (a, fromAdj g) where go (Node a ts) = let as = (fst . unzip . fmap tip) ts in (a, as) : concatMap go ts asTree :: Rooted -> Tree Node -asTree (r,g) = let go a = Node a (fmap go ((IS.toList . f) a)) +asTree (r,g) = let go a = Node a (fmap go ((WS.toList . f) a)) f = (g !) in go r + where (!) g n = maybe mempty id (WM.lookup n g) + reachable :: (Node -> NodeSet) -> (Node -> NodeSet) -reachable f a = go (IS.singleton a) a +reachable f a = go (WS.singleton a) a where go seen a = let s = f a - as = IS.toList (s `IS.difference` seen) - in foldl' go (s `IS.union` seen) as + as = WS.toList (s `WS.difference` seen) + in foldl' go (s `WS.union` seen) as -collectI :: (c -> c -> c) - -> (a -> Int) -> (a -> c) -> [a] -> IntMap c -collectI (<>) f g - = foldl' (\m a -> IM.insertWith (<>) +collectW :: (c -> c -> c) + -> (a -> Node) -> (a -> c) -> [a] -> Word64Map c +collectW (<>) f g + = foldl' (\m a -> WM.insertWith (<>) (f a) (g a) m) mempty @@ -504,12 +527,12 @@ -- Gives nodes sequential names starting at n. -- Returns the new graph and a mapping. -- (renamed, old -> new) -renum :: Int -> Graph -> (Graph, NodeMap Node) +renum :: Int -> Graph -> (CGraph, NodeMap CNode) renum from = (\(_,m,g)->(g,m)) - . IM.foldrWithKey + . WM.foldrWithKey (\i ss (!n,!env,!new)-> let (j,n2,env2) = go n env i - (n3,env3,ss2) = IS.fold + (n3,env3,ss2) = WS.fold (\k (!n,!env,!new)-> case go n env k of (l,n2,env2)-> (n2,env2,l `IS.insert` new)) @@ -517,13 +540,13 @@ new2 = IM.insertWith IS.union j ss2 new in (n3,env3,new2)) (from,mempty,mempty) where go :: Int - -> NodeMap Node + -> NodeMap CNode -> Node - -> (Node,Int,NodeMap Node) + -> (CNode,Int,NodeMap CNode) go !n !env i = - case IM.lookup i env of + case WM.lookup i env of Just j -> (j,n,env) - Nothing -> (n,n+1,IM.insert i n env) + Nothing -> (n,n+1,WM.insert i n env) ----------------------------------------------------------------------------- diff --git a/compiler/GHC/CmmToAsm/Wasm/Asm.hs b/compiler/GHC/CmmToAsm/Wasm/Asm.hs --- a/compiler/GHC/CmmToAsm/Wasm/Asm.hs +++ b/compiler/GHC/CmmToAsm/Wasm/Asm.hs @@ -14,7 +14,7 @@ import Data.ByteString.Builder import Data.Coerce import Data.Foldable -import qualified Data.IntSet as IS +import qualified GHC.Data.Word64Set as WS import Data.Maybe import Data.Semigroup import GHC.Cmm @@ -181,9 +181,9 @@ asmTellSectionHeader k = asmTellTabLine $ ".section " <> k <> ",\"\",@" asmTellDataSection :: - WasmTypeTag w -> IS.IntSet -> SymName -> DataSection -> WasmAsmM () + WasmTypeTag w -> WS.Word64Set -> SymName -> DataSection -> WasmAsmM () asmTellDataSection ty_word def_syms sym DataSection {..} = do - when (getKey (getUnique sym) `IS.member` def_syms) $ asmTellDefSym sym + when (getKey (getUnique sym) `WS.member` def_syms) $ asmTellDefSym sym asmTellSectionHeader sec_name asmTellAlign dataSectionAlignment asmTellTabLine asm_size @@ -420,12 +420,12 @@ asmTellFunc :: WasmTypeTag w -> - IS.IntSet -> + WS.Word64Set -> SymName -> (([SomeWasmType], [SomeWasmType]), FuncBody w) -> WasmAsmM () asmTellFunc ty_word def_syms sym (func_ty, FuncBody {..}) = do - when (getKey (getUnique sym) `IS.member` def_syms) $ asmTellDefSym sym + when (getKey (getUnique sym) `WS.member` def_syms) $ asmTellDefSym sym asmTellSectionHeader $ ".text." <> asm_sym asmTellLine $ asm_sym <> ":" asmTellFuncType sym func_ty diff --git a/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs b/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs --- a/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs +++ b/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs @@ -26,7 +26,7 @@ import qualified Data.ByteString as BS import Data.Foldable import Data.Functor -import qualified Data.IntSet as IS +import qualified GHC.Data.Word64Set as WS import Data.Semigroup import Data.String import Data.Traversable @@ -1553,7 +1553,7 @@ SymDefault -> wasmModifyM $ \s -> s { defaultSyms = - IS.insert + WS.insert (getKey $ getUnique sym) $ defaultSyms s } diff --git a/compiler/GHC/CmmToAsm/Wasm/Types.hs b/compiler/GHC/CmmToAsm/Wasm/Types.hs --- a/compiler/GHC/CmmToAsm/Wasm/Types.hs +++ b/compiler/GHC/CmmToAsm/Wasm/Types.hs @@ -52,7 +52,7 @@ import Data.ByteString (ByteString) import Data.Coerce import Data.Functor -import qualified Data.IntSet as IS +import qualified GHC.Data.Word64Set as WS import Data.Kind import Data.String import Data.Type.Equality @@ -197,7 +197,7 @@ type SymMap = UniqMap SymName -- | No need to remember the symbols. -type SymSet = IS.IntSet +type SymSet = WS.Word64Set type GlobalInfo = (SymName, SomeWasmType) @@ -427,7 +427,7 @@ WasmCodeGenState { wasmPlatform = platform, - defaultSyms = IS.empty, + defaultSyms = WS.empty, funcTypes = emptyUniqMap, funcBodies = emptyUniqMap, 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 @@ -260,7 +260,7 @@ , envConfig :: !LlvmCgConfig -- ^ Configuration for LLVM code gen , envLogger :: !Logger -- ^ Logger , envOutput :: BufHandle -- ^ Output buffer - , envMask :: !Char -- ^ Mask for creating unique values + , envTag :: !Char -- ^ Tag for creating unique values , envFreshMeta :: MetaId -- ^ Supply of fresh metadata IDs , envUniqMeta :: UniqFM Unique MetaId -- ^ Global metadata nodes , envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type @@ -292,12 +292,12 @@ instance MonadUnique LlvmM where getUniqueSupplyM = do - mask <- getEnv envMask - liftIO $! mkSplitUniqSupply mask + tag <- getEnv envTag + liftIO $! mkSplitUniqSupply tag getUniqueM = do - mask <- getEnv envMask - liftIO $! uniqFromMask mask + tag <- getEnv envTag + liftIO $! uniqFromTag tag -- | Lifting of IO actions. Not exported, as we want to encapsulate IO. liftIO :: IO a -> LlvmM a @@ -318,7 +318,7 @@ , envConfig = cfg , envLogger = logger , envOutput = out - , envMask = 'n' + , envTag = 'n' , envFreshMeta = MetaId 0 , envUniqMeta = emptyUFM } diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -77,9 +77,9 @@ , mg_loc = loc , mg_rdr_env = rdr_env }) = do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars - uniq_mask = 's' + uniq_tag = 's' - ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod + ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod name_ppr_ctx loc $ do { hsc_env' <- getHscEnv ; all_passes <- withPlugins (hsc_plugins hsc_env') 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 @@ -248,7 +248,7 @@ import GHC.Types.Name.Ppr import GHC.Types.TyThing import GHC.Types.HpcInfo -import GHC.Types.Unique.Supply (uniqFromMask) +import GHC.Types.Unique.Supply (uniqFromTag) import GHC.Types.Unique.Set import GHC.Utils.Fingerprint ( Fingerprint ) @@ -2595,7 +2595,7 @@ -- -- The id has to be exported for the JS backend. This isn't required for the -- byte-code interpreter but it does no harm to always do it. - u <- uniqFromMask 'I' + u <- uniqFromTag 'I' let binding_name = mkSystemVarName u (fsLit ("BCO_toplevel")) let binding_id = mkExportedVanillaId binding_name (exprType simpl_expr) 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 @@ -155,7 +155,7 @@ import GHC.Types.Unique import GHC.Iface.Errors.Types -import qualified Data.IntSet as I +import qualified GHC.Data.Word64Set as W -- ----------------------------------------------------------------------------- -- Loading the program @@ -340,10 +340,12 @@ -- Note also that we can't always infer the associated module name -- directly from the filename argument. See #13727. is_known_module mod = - (Map.lookup (moduleName (ms_mod mod)) mod_targets == Just (ms_unitid mod)) + is_module_target mod || maybe False is_file_target (ml_hs_file (ms_location mod)) + is_module_target mod = (moduleName (ms_mod mod), ms_unitid mod) `Set.member` mod_targets + is_file_target file = Set.member (withoutExt file) file_targets file_targets = Set.fromList (mapMaybe file_target targets) @@ -354,7 +356,7 @@ TargetFile file _ -> Just (withoutExt (augmentByWorkingDirectory dflags file)) - mod_targets = Map.fromList (mod_target <$> targets) + mod_targets = Set.fromList (mod_target <$> targets) mod_target Target {targetUnitId, targetId} = case targetId of @@ -2834,12 +2836,12 @@ -} -- See Note [ModuleNameSet, efficiency and space leaks] -type ModuleNameSet = M.Map UnitId I.IntSet +type ModuleNameSet = M.Map UnitId W.Word64Set addToModuleNameSet :: UnitId -> ModuleName -> ModuleNameSet -> ModuleNameSet addToModuleNameSet uid mn s = let k = (getKey $ getUnique $ mn) - in M.insertWith (I.union) uid (I.singleton k) s + in M.insertWith (W.union) uid (W.singleton k) s -- | Wait for some dependencies to finish and then read from the given MVar. wait_deps_hug :: MVar HomeUnitGraph -> [BuildResult] -> ReaderT MakeEnv (MaybeT IO) (HomeUnitGraph, ModuleNameSet) @@ -2850,7 +2852,7 @@ let -- Restrict to things which are in the transitive closure to avoid retaining -- reference to loop modules which have already been compiled by other threads. -- See Note [ModuleNameSet, efficiency and space leaks] - !new = udfmRestrictKeysSet (homeUnitEnv_hpt hme) (fromMaybe I.empty $ M.lookup uid module_deps) + !new = udfmRestrictKeysSet (homeUnitEnv_hpt hme) (fromMaybe W.empty $ M.lookup uid module_deps) in hme { homeUnitEnv_hpt = new } return (unitEnv_mapWithKey pruneHomeUnitEnv hug, module_deps) @@ -2865,7 +2867,7 @@ Nothing -> return (hmis, new_deps) Just hmi -> return (hmi:hmis, new_deps) where - unionModuleNameSet = M.unionWith I.union + unionModuleNameSet = M.unionWith W.union -- Executing the pipelines diff --git a/compiler/GHC/HsToCore/Breakpoints.hs b/compiler/GHC/HsToCore/Breakpoints.hs --- a/compiler/GHC/HsToCore/Breakpoints.hs +++ b/compiler/GHC/HsToCore/Breakpoints.hs @@ -27,16 +27,18 @@ breakArray <- GHCi.newBreakArray interp count ccs <- mkCCSArray interp mod count entries + mod_ptr <- GHCi.newModuleName interp (moduleName mod) let locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ] varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ] declsTicks = listArray (0,count-1) [ tick_path t | t <- entries ] return $ emptyModBreaks - { modBreaks_flags = breakArray - , modBreaks_locs = locsTicks - , modBreaks_vars = varsTicks - , modBreaks_decls = declsTicks - , modBreaks_ccs = ccs + { modBreaks_flags = breakArray + , modBreaks_locs = locsTicks + , modBreaks_vars = varsTicks + , modBreaks_decls = declsTicks + , modBreaks_ccs = ccs + , modBreaks_module = mod_ptr } mkCCSArray diff --git a/compiler/GHC/HsToCore/Foreign/JavaScript.hs b/compiler/GHC/HsToCore/Foreign/JavaScript.hs --- a/compiler/GHC/HsToCore/Foreign/JavaScript.hs +++ b/compiler/GHC/HsToCore/Foreign/JavaScript.hs @@ -156,7 +156,7 @@ header_bits = maybe mempty idTag maybe_target idTag i = let (tag, u) = unpkUnique (getUnique i) - in CHeader (char tag <> int u) + in CHeader (char tag <> word64 u) fun_args | null arg_info = empty -- text "void" 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 @@ -64,6 +64,7 @@ import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Panic.Plain +import GHC.Utils.Unique (sameUnique) import GHC.Data.FastString @@ -319,29 +320,29 @@ , Just (i, tc) <- lit = if -- These only show up via the 'HsOverLit' route - | tc == intTyConName -> check i tc minInt maxInt - | tc == wordTyConName -> check i tc minWord maxWord - | tc == int8TyConName -> check i tc (min' @Int8) (max' @Int8) - | tc == int16TyConName -> check i tc (min' @Int16) (max' @Int16) - | tc == int32TyConName -> check i tc (min' @Int32) (max' @Int32) - | tc == int64TyConName -> check i tc (min' @Int64) (max' @Int64) - | tc == word8TyConName -> check i tc (min' @Word8) (max' @Word8) - | tc == word16TyConName -> check i tc (min' @Word16) (max' @Word16) - | tc == word32TyConName -> check i tc (min' @Word32) (max' @Word32) - | tc == word64TyConName -> check i tc (min' @Word64) (max' @Word64) - | tc == naturalTyConName -> checkPositive i tc + | sameUnique tc intTyConName -> check i tc minInt maxInt + | sameUnique tc wordTyConName -> check i tc minWord maxWord + | sameUnique tc int8TyConName -> check i tc (min' @Int8) (max' @Int8) + | sameUnique tc int16TyConName -> check i tc (min' @Int16) (max' @Int16) + | sameUnique tc int32TyConName -> check i tc (min' @Int32) (max' @Int32) + | sameUnique tc int64TyConName -> check i tc (min' @Int64) (max' @Int64) + | sameUnique tc word8TyConName -> check i tc (min' @Word8) (max' @Word8) + | sameUnique tc word16TyConName -> check i tc (min' @Word16) (max' @Word16) + | sameUnique tc word32TyConName -> check i tc (min' @Word32) (max' @Word32) + | sameUnique tc word64TyConName -> check i tc (min' @Word64) (max' @Word64) + | sameUnique tc naturalTyConName -> checkPositive i tc -- These only show up via the 'HsLit' route - | tc == intPrimTyConName -> check i tc minInt maxInt - | tc == wordPrimTyConName -> check i tc minWord maxWord - | tc == int8PrimTyConName -> check i tc (min' @Int8) (max' @Int8) - | tc == int16PrimTyConName -> check i tc (min' @Int16) (max' @Int16) - | tc == int32PrimTyConName -> check i tc (min' @Int32) (max' @Int32) - | tc == int64PrimTyConName -> check i tc (min' @Int64) (max' @Int64) - | tc == word8PrimTyConName -> check i tc (min' @Word8) (max' @Word8) - | tc == word16PrimTyConName -> check i tc (min' @Word16) (max' @Word16) - | tc == word32PrimTyConName -> check i tc (min' @Word32) (max' @Word32) - | tc == word64PrimTyConName -> check i tc (min' @Word64) (max' @Word64) + | sameUnique tc intPrimTyConName -> check i tc minInt maxInt + | sameUnique tc wordPrimTyConName -> check i tc minWord maxWord + | sameUnique tc int8PrimTyConName -> check i tc (min' @Int8) (max' @Int8) + | sameUnique tc int16PrimTyConName -> check i tc (min' @Int16) (max' @Int16) + | sameUnique tc int32PrimTyConName -> check i tc (min' @Int32) (max' @Int32) + | sameUnique tc int64PrimTyConName -> check i tc (min' @Int64) (max' @Int64) + | sameUnique tc word8PrimTyConName -> check i tc (min' @Word8) (max' @Word8) + | sameUnique tc word16PrimTyConName -> check i tc (min' @Word16) (max' @Word16) + | sameUnique tc word32PrimTyConName -> check i tc (min' @Word32) (max' @Word32) + | sameUnique tc word64PrimTyConName -> check i tc (min' @Word64) (max' @Word64) | otherwise -> return () @@ -398,22 +399,22 @@ platform <- targetPlatform <$> getDynFlags -- Be careful to use target Int/Word sizes! cf #17336 - if | tc == intTyConName -> case platformWordSize platform of - PW4 -> check @Int32 - PW8 -> check @Int64 - | tc == wordTyConName -> case platformWordSize platform of - PW4 -> check @Word32 - PW8 -> check @Word64 - | tc == int8TyConName -> check @Int8 - | tc == int16TyConName -> check @Int16 - | tc == int32TyConName -> check @Int32 - | tc == int64TyConName -> check @Int64 - | tc == word8TyConName -> check @Word8 - | tc == word16TyConName -> check @Word16 - | tc == word32TyConName -> check @Word32 - | tc == word64TyConName -> check @Word64 - | tc == integerTyConName -> check @Integer - | tc == naturalTyConName -> check @Integer + if | sameUnique tc intTyConName -> case platformWordSize platform of + PW4 -> check @Int32 + PW8 -> check @Int64 + | sameUnique tc wordTyConName -> case platformWordSize platform of + PW4 -> check @Word32 + PW8 -> check @Word64 + | sameUnique tc int8TyConName -> check @Int8 + | sameUnique tc int16TyConName -> check @Int16 + | sameUnique tc int32TyConName -> check @Int32 + | sameUnique tc int64TyConName -> check @Int64 + | sameUnique tc word8TyConName -> check @Word8 + | sameUnique tc word16TyConName -> check @Word16 + | sameUnique tc word32TyConName -> check @Word32 + | sameUnique tc word64TyConName -> check @Word64 + | sameUnique tc integerTyConName -> check @Integer + | sameUnique tc naturalTyConName -> check @Integer -- We use 'Integer' because otherwise a negative 'Natural' literal -- could cause a compile time crash (instead of a runtime one). -- See the T10930b test case for an example of where this matters. diff --git a/compiler/GHC/Linker/Deps.hs b/compiler/GHC/Linker/Deps.hs --- a/compiler/GHC/Linker/Deps.hs +++ b/compiler/GHC/Linker/Deps.hs @@ -1,3 +1,8 @@ +-- The transition from Int to Word64 for uniques makes functions slightly larger +-- without this GHC option some optimizations fail to fire. +-- See https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10568#note_505751 +{-# OPTIONS_GHC -fspec-constr-threshold=10000 #-} + {-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections, RecordWildCards #-} {-# LANGUAGE BangPatterns #-} diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -325,15 +325,14 @@ | otherwise = not_tracing where tracing - | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt _ccs <- status + | EvalBreak is_exception apStack_ref ix mod_name resume_ctxt _ccs <- status , not is_exception = do hsc_env <- getSession let interp = hscInterp hsc_env let dflags = hsc_dflags hsc_env let hmi = expectJust "handleRunStatus" $ - lookupHptDirectly (hsc_HPT hsc_env) - (mkUniqueGrimily mod_uniq) + lookupHpt (hsc_HPT hsc_env) (mkModuleName mod_name) modl = mi_module (hm_iface hmi) breaks = getModBreaks hmi @@ -358,15 +357,14 @@ not_tracing -- Hit a breakpoint - | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt ccs <- status + | EvalBreak is_exception apStack_ref ix mod_name resume_ctxt ccs <- status = do hsc_env <- getSession let interp = hscInterp hsc_env resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref let hmi = expectJust "handleRunStatus" $ - lookupHptDirectly (hsc_HPT hsc_env) - (mkUniqueGrimily mod_uniq) + lookupHpt (hsc_HPT hsc_env) (mkModuleName mod_name) modl = mi_module (hm_iface hmi) bp | is_exception = Nothing | otherwise = Just (BreakInfo modl ix) diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs --- a/compiler/GHC/Runtime/Interpreter.hs +++ b/compiler/GHC/Runtime/Interpreter.hs @@ -25,6 +25,7 @@ , mkCostCentres , costCentreStackInfo , newBreakArray + , newModuleName , storeBreakpoint , breakpointStatus , getBreakpointVar @@ -84,7 +85,6 @@ import GHC.Data.Maybe import GHC.Data.FastString -import GHC.Types.Unique import GHC.Types.SrcLoc import GHC.Types.Unique.FM import GHC.Types.Basic @@ -381,6 +381,10 @@ breakArray <- interpCmd interp (NewBreakArray size) mkFinalizedHValue interp breakArray +newModuleName :: Interp -> ModuleName -> IO (RemotePtr ModuleName) +newModuleName interp mod_name = + castRemotePtr <$> interpCmd interp (NewBreakModule (moduleNameString mod_name)) + storeBreakpoint :: Interp -> ForeignRef BreakArray -> Int -> Int -> IO () storeBreakpoint interp ref ix cnt = do -- #19157 withForeignRef ref $ \breakarray -> @@ -414,13 +418,12 @@ handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus () -> IO (EvalResult ()) handleSeqHValueStatus interp unit_env eval_status = case eval_status of - (EvalBreak is_exception _ ix mod_uniq resume_ctxt _) -> do + (EvalBreak is_exception _ ix mod_name resume_ctxt _) -> do -- A breakpoint was hit; inform the user and tell them -- which breakpoint was hit. resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt let hmi = expectJust "handleRunStatus" $ - lookupHptDirectly (ue_hpt unit_env) - (mkUniqueGrimily mod_uniq) + lookupHpt (ue_hpt unit_env) (mkModuleName mod_name) modl = mi_module (hm_iface hmi) bp | is_exception = Nothing | otherwise = Just (BreakInfo modl ix) diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs --- a/compiler/GHC/Stg/Pipeline.hs +++ b/compiler/GHC/Stg/Pipeline.hs @@ -58,10 +58,10 @@ deriving (Functor, Applicative, Monad, MonadIO) instance MonadUnique StgM where - getUniqueSupplyM = StgM $ do { mask <- ask - ; liftIO $! mkSplitUniqSupply mask} - getUniqueM = StgM $ do { mask <- ask - ; liftIO $! uniqFromMask mask} + getUniqueSupplyM = StgM $ do { tag <- ask + ; liftIO $! mkSplitUniqSupply tag} + getUniqueM = StgM $ do { tag <- ask + ; liftIO $! uniqFromTag tag} runStgM :: Char -> StgM a -> IO a runStgM mask (StgM m) = runReaderT m mask diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs --- a/compiler/GHC/StgToByteCode.hs +++ b/compiler/GHC/StgToByteCode.hs @@ -53,7 +53,6 @@ import GHC.Builtin.Types.Prim import GHC.Core.TyCo.Ppr ( pprType ) import GHC.Utils.Error -import GHC.Types.Unique import GHC.Builtin.Uniques import GHC.Data.FastString import GHC.Utils.Panic @@ -392,7 +391,6 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs) rhs) = do code <- schemeE d 0 p rhs cc_arr <- getCCArray - this_mod <- moduleName <$> getCurrentModule platform <- profilePlatform <$> getProfile let idOffSets = getVarOffSets platform d p fvs ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs) @@ -405,8 +403,12 @@ , interpreterProfiled interp = cc_arr ! tick_no | otherwise = toRemotePtr nullPtr - let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc - return $ breakInstr `consOL` code + mb_mod_name <- getCurrentModuleName + case mb_mod_name of + Just mod_ptr -> do + let breakInstr = BRK_FUN (fromIntegral tick_no) mod_ptr cc + return $ breakInstr `consOL` code + Nothing -> return code schemeER_wrk d p rhs = schemeE d 0 p rhs getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, WordOff)] @@ -2263,8 +2265,8 @@ newBreakInfo ix info = BcM $ \st -> return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ()) -getCurrentModule :: BcM Module -getCurrentModule = BcM $ \st -> return (st, thisModule st) +getCurrentModuleName :: BcM (Maybe (RemotePtr ModuleName)) +getCurrentModuleName = BcM $ \st -> return (st, modBreaks_module <$> modBreaks st) tickFS :: FastString tickFS = fsLit "ticked" diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -157,6 +157,7 @@ import GHC.StgToCmm.Env (getCgInfo_maybe) import Data.Coerce (coerce) import GHC.Utils.Json +import GHC.Utils.Unique (anyOfUnique) ----------------------------------------------------------------------------- -- @@ -884,20 +885,19 @@ | otherwise = case tcSplitTyConApp_maybe ty of Nothing -> '.' Just (tycon, _) -> - let anyOf us = getUnique tycon `elem` us in case () of - _ | anyOf [fUNTyConKey] -> '>' - | anyOf [charTyConKey] -> 'C' - | anyOf [charPrimTyConKey] -> 'c' - | anyOf [doubleTyConKey] -> 'D' - | anyOf [doublePrimTyConKey] -> 'd' - | anyOf [floatTyConKey] -> 'F' - | anyOf [floatPrimTyConKey] -> 'f' - | anyOf [intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey] -> 'I' - | anyOf [intPrimTyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int64PrimTyConKey] -> 'i' - | anyOf [wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey] -> 'W' - | anyOf [wordPrimTyConKey, word8PrimTyConKey, word16PrimTyConKey, word32PrimTyConKey, word64PrimTyConKey] -> 'w' - | anyOf [listTyConKey] -> 'L' + _ | anyOfUnique tycon [fUNTyConKey] -> '>' + | anyOfUnique tycon [charTyConKey] -> 'C' + | anyOfUnique tycon [charPrimTyConKey] -> 'c' + | anyOfUnique tycon [doubleTyConKey] -> 'D' + | anyOfUnique tycon [doublePrimTyConKey] -> 'd' + | anyOfUnique tycon [floatTyConKey] -> 'F' + | anyOfUnique tycon [floatPrimTyConKey] -> 'f' + | anyOfUnique tycon [intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey] -> 'I' + | anyOfUnique tycon [intPrimTyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int64PrimTyConKey] -> 'i' + | anyOfUnique tycon [wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey] -> 'W' + | anyOfUnique tycon [wordPrimTyConKey, word8PrimTyConKey, word16PrimTyConKey, word32PrimTyConKey, word64PrimTyConKey] -> 'w' + | anyOfUnique tycon [listTyConKey] -> 'L' | isUnboxedTupleTyCon tycon -> 't' | isTupleTyCon tycon -> 'T' | isPrimTyCon tycon -> 'P' diff --git a/compiler/GHC/StgToJS/Deps.hs b/compiler/GHC/StgToJS/Deps.hs --- a/compiler/GHC/StgToJS/Deps.hs +++ b/compiler/GHC/StgToJS/Deps.hs @@ -45,18 +45,19 @@ import qualified Data.Map as M import qualified Data.Set as S import qualified Data.IntSet as IS -import qualified Data.IntMap as IM -import Data.IntMap (IntMap) +import qualified GHC.Data.Word64Map as WM +import GHC.Data.Word64Map (Word64Map) import Data.Array import Data.Either +import Data.Word import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.State data DependencyDataCache = DDC - { ddcModule :: !(IntMap Unit) -- ^ Unique Module -> Unit - , ddcId :: !(IntMap ExportedFun) -- ^ Unique Id -> ExportedFun (only to other modules) + { ddcModule :: !(Word64Map Unit) -- ^ Unique Module -> Unit + , ddcId :: !(Word64Map ExportedFun) -- ^ Unique Id -> ExportedFun (only to other modules) , ddcOther :: !(Map OtherSymb ExportedFun) } @@ -71,7 +72,7 @@ -> G BlockInfo genDependencyData mod units = do ds <- evalStateT (mapM (uncurry oneDep) blocks) - (DDC IM.empty IM.empty M.empty) + (DDC WM.empty WM.empty M.empty) return $ BlockInfo { bi_module = mod , bi_must_link = IS.fromList [ n | (n, _, True, _) <- ds ] @@ -144,7 +145,7 @@ in if m == mod then pprPanic "local id not found" (ppr m) else Left <$> do - mr <- gets (IM.lookup k . ddcId) + mr <- gets (WM.lookup k . ddcId) maybe addEntry return mr -- get the function for an OtherSymb from the cache, add it if necessary @@ -167,7 +168,7 @@ -- lookup a dependency to another module, add to the id cache if there's -- an id key, otherwise add to other cache - lookupExternalFun :: Maybe Int + lookupExternalFun :: Maybe Word64 -> OtherSymb -> StateT DependencyDataCache G ExportedFun lookupExternalFun mbIdKey od@(OtherSymb m idTxt) = do let mk = getKey . getUnique $ m @@ -175,17 +176,17 @@ exp_fun = ExportedFun m (LexicalFastString idTxt) addCache = do ms <- gets ddcModule - let !cache' = IM.insert mk mpk ms + let !cache' = WM.insert mk mpk ms modify (\s -> s { ddcModule = cache'}) pure exp_fun f <- do - mbm <- gets (IM.member mk . ddcModule) + mbm <- gets (WM.member mk . ddcModule) case mbm of False -> addCache True -> pure exp_fun case mbIdKey of Nothing -> modify (\s -> s { ddcOther = M.insert od f (ddcOther s) }) - Just k -> modify (\s -> s { ddcId = IM.insert k f (ddcId s) }) + Just k -> modify (\s -> s { ddcId = WM.insert k f (ddcId s) }) return f diff --git a/compiler/GHC/StgToJS/Ids.hs b/compiler/GHC/StgToJS/Ids.hs --- a/compiler/GHC/StgToJS/Ids.hs +++ b/compiler/GHC/StgToJS/Ids.hs @@ -131,7 +131,7 @@ , if exported then mempty else let (c,u) = unpkUnique (getUnique i) - in mconcat [BSC.pack ['_',c,'_'], intBS u] + in mconcat [BSC.pack ['_',c,'_'], word64BS u] ] -- | Retrieve the cached Ident for the given Id if there is one. Otherwise make diff --git a/compiler/GHC/StgToJS/Symbols.hs b/compiler/GHC/StgToJS/Symbols.hs --- a/compiler/GHC/StgToJS/Symbols.hs +++ b/compiler/GHC/StgToJS/Symbols.hs @@ -8,23 +8,32 @@ , mkFreshJsSymbol , mkRawSymbol , intBS + , word64BS ) where import GHC.Prelude import GHC.Data.FastString import GHC.Unit.Module +import GHC.Utils.Word64 (intToWord64) import Data.ByteString (ByteString) +import Data.Word (Word64) import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Lazy as BSL -- | Hexadecimal representation of an int -- +-- Used for the sub indices. +intBS :: Int -> ByteString +intBS = word64BS . intToWord64 + +-- | Hexadecimal representation of a 64-bit word +-- -- Used for uniques. We could use base-62 as GHC usually does but this is likely -- faster. -intBS :: Int -> ByteString -intBS = BSL.toStrict . BSB.toLazyByteString . BSB.wordHex . fromIntegral +word64BS :: Word64 -> ByteString +word64BS = BSL.toStrict . BSB.toLazyByteString . BSB.word64Hex -- | Return z-encoded unit:module unitModuleStringZ :: Module -> ByteString diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs --- a/compiler/GHC/Tc/Deriv/Utils.hs +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -66,6 +66,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Error +import GHC.Utils.Unique (sameUnique) import Control.Monad.Trans.Reader import Data.Foldable (traverse_) @@ -893,37 +894,37 @@ -- class for which stock deriving isn't possible. stockSideConditions :: DerivContext -> Class -> Maybe Condition stockSideConditions deriv_ctxt cls - | cls_key == eqClassKey = Just (cond_std `andCond` cond_args cls) - | cls_key == ordClassKey = Just (cond_std `andCond` cond_args cls) - | cls_key == showClassKey = Just (cond_std `andCond` cond_args cls) - | cls_key == readClassKey = Just (cond_std `andCond` cond_args cls) - | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration) - | cls_key == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct cls) - | cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct cls) - | cls_key == dataClassKey = Just (checkFlag LangExt.DeriveDataTypeable `andCond` - cond_vanilla `andCond` - cond_args cls) - | cls_key == functorClassKey = Just (checkFlag LangExt.DeriveFunctor `andCond` - cond_vanilla `andCond` - cond_functorOK True False) - | cls_key == foldableClassKey = Just (checkFlag LangExt.DeriveFoldable `andCond` - cond_vanilla `andCond` - cond_functorOK False True) - -- Functor/Fold/Trav works ok - -- for rank-n types - | cls_key == traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond` - cond_vanilla `andCond` - cond_functorOK False False) - | cls_key == genClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond` - cond_vanilla `andCond` - cond_RepresentableOk) - | cls_key == gen1ClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond` - cond_vanilla `andCond` - cond_Representable1Ok) - | cls_key == liftClassKey = Just (checkFlag LangExt.DeriveLift `andCond` - cond_vanilla `andCond` - cond_args cls) - | otherwise = Nothing + | sameUnique cls_key eqClassKey = Just (cond_std `andCond` cond_args cls) + | sameUnique cls_key ordClassKey = Just (cond_std `andCond` cond_args cls) + | sameUnique cls_key showClassKey = Just (cond_std `andCond` cond_args cls) + | sameUnique cls_key readClassKey = Just (cond_std `andCond` cond_args cls) + | sameUnique cls_key enumClassKey = Just (cond_std `andCond` cond_isEnumeration) + | sameUnique cls_key ixClassKey = Just (cond_std `andCond` cond_enumOrProduct cls) + | sameUnique cls_key boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct cls) + | sameUnique cls_key dataClassKey = Just (checkFlag LangExt.DeriveDataTypeable `andCond` + cond_vanilla `andCond` + cond_args cls) + | sameUnique cls_key functorClassKey = Just (checkFlag LangExt.DeriveFunctor `andCond` + cond_vanilla `andCond` + cond_functorOK True False) + | sameUnique cls_key foldableClassKey = Just (checkFlag LangExt.DeriveFoldable `andCond` + cond_vanilla `andCond` + cond_functorOK False True) + -- Functor/Fold/Trav works ok + -- for rank-n types + | sameUnique cls_key traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond` + cond_vanilla `andCond` + cond_functorOK False False) + | sameUnique cls_key genClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond` + cond_vanilla `andCond` + cond_RepresentableOk) + | sameUnique cls_key gen1ClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond` + cond_vanilla `andCond` + cond_Representable1Ok) + | sameUnique cls_key liftClassKey = Just (checkFlag LangExt.DeriveLift `andCond` + cond_vanilla `andCond` + cond_args cls) + | otherwise = Nothing where cls_key = getUnique cls cond_std = cond_stdOK deriv_ctxt False diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -71,6 +71,7 @@ import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic +import GHC.Utils.Unique import GHC.Platform import GHC.Data.Bag @@ -741,16 +742,16 @@ boxedMarshalableTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason boxedMarshalableTyCon tc - | getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey - , int32TyConKey, int64TyConKey - , wordTyConKey, word8TyConKey, word16TyConKey - , word32TyConKey, word64TyConKey - , floatTyConKey, doubleTyConKey - , ptrTyConKey, funPtrTyConKey - , charTyConKey - , stablePtrTyConKey - , boolTyConKey - ] + | anyOfUnique tc [ intTyConKey, int8TyConKey, int16TyConKey + , int32TyConKey, int64TyConKey + , wordTyConKey, word8TyConKey, word16TyConKey + , word32TyConKey, word64TyConKey + , floatTyConKey, doubleTyConKey + , ptrTyConKey, funPtrTyConKey + , charTyConKey + , stablePtrTyConKey + , boolTyConKey + ] = IsValid | otherwise = NotValid NotABoxedMarshalableTyCon 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 @@ -90,6 +90,7 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Outputable +import GHC.Utils.Unique (sameUnique) import GHC.Unit.State import GHC.Unit.External @@ -792,17 +793,17 @@ in hasFixedRuntimeRep_syntactic (FRRArrow $ ArrowFun user_expr) res_ty mb_arity :: Maybe Arity mb_arity -- arity of the arrow operation, counting type-level arguments - | std_nm == arrAName -- result used as an argument in, e.g., do_premap + | sameUnique std_nm arrAName -- result used as an argument in, e.g., do_premap = Just 3 - | std_nm == composeAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt + | sameUnique std_nm composeAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt = Just 5 - | std_nm == firstAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt + | sameUnique std_nm firstAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt = Just 4 - | std_nm == appAName -- result used as an argument in, e.g., dsCmd/HsCmdArrApp/HsHigherOrderApp + | sameUnique std_nm appAName -- result used as an argument in, e.g., dsCmd/HsCmdArrApp/HsHigherOrderApp = Just 2 - | std_nm == choiceAName -- result used as an argument in, e.g., HsCmdIf + | sameUnique std_nm choiceAName -- result used as an argument in, e.g., HsCmdIf = Just 5 - | std_nm == loopAName -- result used as an argument in, e.g., HsCmdIf + | sameUnique std_nm loopAName -- result used as an argument in, e.g., HsCmdIf = Just 4 | otherwise = Nothing diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -454,14 +454,14 @@ ************************************************************************ -} -initTcRnIf :: Char -- ^ Mask for unique supply +initTcRnIf :: Char -- ^ Tag for unique supply -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a -initTcRnIf uniq_mask hsc_env gbl_env lcl_env thing_inside +initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside = do { let { env = Env { env_top = hsc_env, - env_um = uniq_mask, + env_ut = uniq_tag, env_gbl = gbl_env, env_lcl = lcl_env} } @@ -717,14 +717,14 @@ newUnique :: TcRnIf gbl lcl Unique newUnique = do { env <- getEnv - ; let mask = env_um env - ; liftIO $! uniqFromMask mask } + ; let tag = env_ut env + ; liftIO $! uniqFromTag tag } newUniqueSupply :: TcRnIf gbl lcl UniqSupply newUniqueSupply = do { env <- getEnv - ; let mask = env_um env - ; liftIO $! mkSplitUniqSupply mask } + ; let tag = env_ut env + ; liftIO $! mkSplitUniqSupply tag } cloneLocalName :: Name -> TcM Name -- Make a fresh Internal name with the same OccName and SrcSpan diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -63,6 +63,7 @@ import Data.List.NonEmpty( NonEmpty (..), nonEmpty ) import qualified Data.List.NonEmpty as NE import Data.Maybe( catMaybes, isNothing ) +import Data.Word (Word64) import Language.Haskell.TH as TH hiding (sigP) import Language.Haskell.TH.Syntax as TH import Foreign.ForeignPtr @@ -2199,7 +2200,7 @@ mk_pkg :: TH.PkgName -> Unit mk_pkg pkg = stringToUnit (TH.pkgString pkg) -mk_uniq :: Int -> Unique +mk_uniq :: Word64 -> Unique mk_uniq u = mkUniqueGrimily u {- diff --git a/compiler/GHC/Utils/Unique.hs b/compiler/GHC/Utils/Unique.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Utils/Unique.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE CPP #-} + +{- Work around #23537 + +On 32 bit systems, GHC's codegen around 64 bit numbers is not quite +complete. This led to panics mentioning missing cases in iselExpr64. +Now that GHC uses Word64 for its uniques, these panics have started +popping up whenever a unique is compared to many other uniques in one +function. As a workaround we use these two functions which are not +inlined on 32 bit systems, thus preventing the panics. +-} + +module GHC.Utils.Unique (sameUnique, anyOfUnique) where + +#include "MachDeps.h" + +import GHC.Prelude.Basic (Bool, Eq((==)), Foldable(elem)) +import GHC.Types.Unique (Unique, Uniquable (getUnique)) + + +#if WORD_SIZE_IN_BITS == 32 +{-# NOINLINE sameUnique #-} +#else +{-# INLINE sameUnique #-} +#endif +sameUnique :: Uniquable a => a -> a -> Bool +sameUnique x y = getUnique x == getUnique y + +#if WORD_SIZE_IN_BITS == 32 +{-# NOINLINE anyOfUnique #-} +#else +{-# INLINE anyOfUnique #-} +#endif +anyOfUnique :: Uniquable a => a -> [Unique] -> Bool +anyOfUnique tc xs = getUnique tc `elem` xs diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: ghc-lib -version: 9.8.3.20241103 +version: 9.8.4.20241130 license: BSD-3-Clause license-file: LICENSE category: Development @@ -78,10 +78,10 @@ build-depends: base >= 4.17 && < 4.20, ghc-prim > 0.2 && < 0.12, - containers >= 0.6.2.1 && < 0.7, + containers >= 0.6.2.1 && < 0.8, bytestring >= 0.11.4 && < 0.13, - time >= 1.4 && < 1.13, - filepath >= 1 && < 1.5, + time >= 1.4 && < 1.15, + filepath >= 1.5 && < 1.6, exceptions == 0.10.*, parsec, binary == 0.8.*, @@ -95,8 +95,8 @@ semaphore-compat, rts, hpc >= 0.6 && < 0.8, - ghc-lib-parser == 9.8.3.20241103 - build-tool-depends: alex:alex >= 3.1, happy:happy == 1.20.* || >= 2.0.2 && < 2.1 + ghc-lib-parser == 9.8.4.20241130 + build-tool-depends: alex:alex >= 3.1, happy:happy == 1.20.* || == 2.0.2 || >= 2.1.2 && < 2.2 other-extensions: BangPatterns CPP @@ -250,6 +250,13 @@ GHC.Data.StringBuffer, GHC.Data.TrieMap, GHC.Data.Unboxed, + GHC.Data.Word64Map, + GHC.Data.Word64Map.Internal, + GHC.Data.Word64Map.Lazy, + GHC.Data.Word64Map.Strict, + GHC.Data.Word64Map.Strict.Internal, + GHC.Data.Word64Set, + GHC.Data.Word64Set.Internal, GHC.Driver.Backend, GHC.Driver.Backend.Internal, GHC.Driver.Backpack.Syntax, @@ -490,6 +497,8 @@ GHC.Utils.BufHandle, GHC.Utils.CliOption, GHC.Utils.Constants, + GHC.Utils.Containers.Internal.BitUtil, + GHC.Utils.Containers.Internal.StrictPair, GHC.Utils.Encoding, GHC.Utils.Encoding.UTF8, GHC.Utils.Error, @@ -511,6 +520,7 @@ GHC.Utils.Ppr.Colour, GHC.Utils.TmpFs, GHC.Utils.Trace, + GHC.Utils.Word64, GHC.Version, GHCi.BreakArray, GHCi.FFI, @@ -923,6 +933,7 @@ GHC.Unit.Finder GHC.Utils.Asm GHC.Utils.Monad.Codensity + GHC.Utils.Unique GHC.Wasm.ControlFlow GHC.Wasm.ControlFlow.FromCmm GHCi.BinaryArray diff --git a/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl b/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl @@ -11,7 +11,7 @@ primOpStrictness MaskAsyncExceptionsOp = \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv primOpStrictness MaskUninterruptibleOp = \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv primOpStrictness UnmaskAsyncExceptionsOp = \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv -primOpStrictness PromptOp = \ _arity -> mkClosedDmdSig [topDmd, strictOnceApply1Dmd, topDmd] topDiv +primOpStrictness PromptOp = \ _arity -> mkClosedDmdSig [topDmd, lazyApply1Dmd, topDmd] topDiv primOpStrictness Control0Op = \ _arity -> mkClosedDmdSig [topDmd, lazyApply2Dmd, topDmd] topDiv primOpStrictness AtomicallyOp = \ _arity -> mkClosedDmdSig [strictManyApply1Dmd,topDmd] topDiv primOpStrictness RetryOp = \ _arity -> mkClosedDmdSig [topDmd] botDiv