ghc-lib 9.8.3.20241103 → 9.8.4.20241130
raw patch · 35 files changed
+401/−295 lines, 35 filesdep ~containersdep ~filepathdep ~ghc-lib-parserPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: containers, filepath, ghc-lib-parser, time
API changes (from Hackage documentation)
- GHC.CmmToAsm.CFG.Dominators: asGraph :: Tree Node -> Rooted
+ GHC: [modBreaks_module] :: ModBreaks -> RemotePtr ModuleName
+ GHC.CmmToAsm.CFG.Dominators: asCGraph :: Tree Node -> Rooted
+ GHC.Runtime.Interpreter: [NewBreakModule] :: String -> Message (RemotePtr BreakModule)
+ GHC.Runtime.Interpreter: newModuleName :: Interp -> ModuleName -> IO (RemotePtr ModuleName)
+ GHC.Runtime.Interpreter.Process: [NewBreakModule] :: String -> Message (RemotePtr BreakModule)
+ GHC.StgToJS.Symbols: word64BS :: Word64 -> ByteString
+ GHC.Utils.Unique: anyOfUnique :: Uniquable a => a -> [Unique] -> Bool
+ GHC.Utils.Unique: sameUnique :: Uniquable a => a -> a -> Bool
- GHC: DynFlags :: GhcMode -> GhcLink -> !Backend -> {-# UNPACK #-} !GhcNameVersion -> {-# UNPACK #-} !FileSettings -> Platform -> {-# UNPACK #-} !ToolSettings -> {-# UNPACK #-} !PlatformMisc -> [(String, String)] -> TempDir -> Int -> Int -> Int -> Int -> Int -> Maybe String -> [Int] -> Maybe ParMakeCount -> Bool -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Int -> Int -> Int -> !Int -> Maybe Int -> Maybe Int -> Int -> Maybe Word -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Bool -> Maybe Int -> Int -> [FilePath] -> ModuleName -> Maybe String -> IntWithInf -> IntWithInf -> Int -> Int -> Int -> UnitId -> Maybe UnitId -> [(ModuleName, Module)] -> Maybe FilePath -> Maybe String -> Set ModuleName -> Set ModuleName -> Ways -> Maybe (String, Int) -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> String -> String -> String -> String -> String -> String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> DynLibLoader -> !Bool -> FilePath -> Maybe FilePath -> [Option] -> IncludeSpecs -> [String] -> [String] -> [String] -> Maybe String -> RtsOptsEnabled -> Bool -> String -> [ModuleName] -> [(ModuleName, String)] -> [String] -> [ExternalPluginSpec] -> FilePath -> Bool -> Bool -> [ModuleName] -> [String] -> [PackageDBFlag] -> [IgnorePackageFlag] -> [PackageFlag] -> [PackageFlag] -> [TrustFlag] -> Maybe FilePath -> EnumSet DumpFlag -> EnumSet GeneralFlag -> EnumSet WarningFlag -> EnumSet WarningFlag -> WarningCategorySet -> WarningCategorySet -> Maybe Language -> SafeHaskellMode -> Bool -> Bool -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> [OnOff Extension] -> EnumSet Extension -> !UnfoldingOpts -> Int -> Int -> FlushOut -> Maybe FilePath -> Maybe String -> [String] -> Int -> Int -> Bool -> OverridingBool -> Bool -> Scheme -> ProfAuto -> [CallerCcFilter] -> Maybe String -> Maybe SseVersion -> Maybe BmiVersion -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> IORef (Maybe LinkerInfo) -> IORef (Maybe CompilerInfo) -> IORef (Maybe CompilerInfo) -> Int -> Int -> Int -> Bool -> Maybe Int -> Word -> Int -> Weights -> DynFlags
+ GHC: DynFlags :: GhcMode -> GhcLink -> !Backend -> {-# UNPACK #-} !GhcNameVersion -> {-# UNPACK #-} !FileSettings -> Platform -> {-# UNPACK #-} !ToolSettings -> {-# UNPACK #-} !PlatformMisc -> [(String, String)] -> TempDir -> Int -> Int -> Int -> Int -> Int -> Maybe String -> [Int] -> Maybe ParMakeCount -> Bool -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Int -> Int -> Int -> !Int -> Maybe Int -> Maybe Int -> Int -> Maybe Word -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Bool -> Maybe Int -> Int -> [FilePath] -> ModuleName -> Maybe String -> IntWithInf -> IntWithInf -> Int -> Int -> Int -> UnitId -> Maybe UnitId -> [(ModuleName, Module)] -> Maybe FilePath -> Maybe String -> Set ModuleName -> Set ModuleName -> Ways -> Maybe (String, Int) -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> String -> String -> String -> String -> String -> String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> DynLibLoader -> !Bool -> FilePath -> Maybe FilePath -> [Option] -> IncludeSpecs -> [String] -> [String] -> [String] -> Maybe String -> RtsOptsEnabled -> Bool -> String -> [ModuleName] -> [(ModuleName, String)] -> [String] -> [ExternalPluginSpec] -> FilePath -> Bool -> Bool -> [ModuleName] -> [String] -> [PackageDBFlag] -> [IgnorePackageFlag] -> [PackageFlag] -> [PackageFlag] -> [TrustFlag] -> Maybe FilePath -> EnumSet DumpFlag -> EnumSet GeneralFlag -> EnumSet WarningFlag -> EnumSet WarningFlag -> WarningCategorySet -> WarningCategorySet -> Maybe Language -> SafeHaskellMode -> Bool -> Bool -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> [OnOff Extension] -> EnumSet Extension -> !UnfoldingOpts -> Int -> Int -> FlushOut -> Maybe FilePath -> Maybe String -> [String] -> Int -> Int -> Bool -> OverridingBool -> Bool -> Scheme -> ProfAuto -> [CallerCcFilter] -> Maybe String -> Maybe SseVersion -> Maybe BmiVersion -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> IORef (Maybe LinkerInfo) -> IORef (Maybe CompilerInfo) -> IORef (Maybe CompilerInfo) -> Int -> Int -> Int -> Bool -> Maybe Int -> Word64 -> Int -> Weights -> DynFlags
- GHC: ModBreaks :: ForeignRef BreakArray -> !Array BreakIndex SrcSpan -> !Array BreakIndex [OccName] -> !Array BreakIndex [String] -> !Array BreakIndex (RemotePtr CostCentre) -> IntMap CgBreakInfo -> ModBreaks
+ GHC: ModBreaks :: ForeignRef BreakArray -> !Array BreakIndex SrcSpan -> !Array BreakIndex [OccName] -> !Array BreakIndex [String] -> !Array BreakIndex (RemotePtr CostCentre) -> IntMap CgBreakInfo -> RemotePtr ModuleName -> ModBreaks
- GHC: [initialUnique] :: DynFlags -> Word
+ GHC: [initialUnique] :: DynFlags -> Word64
- GHC.ByteCode.Instr: BRK_FUN :: !Word16 -> Unique -> RemotePtr CostCentre -> BCInstr
+ GHC.ByteCode.Instr: BRK_FUN :: !Word16 -> RemotePtr ModuleName -> RemotePtr CostCentre -> BCInstr
- GHC.Cmm.LRegSet: elemsLRegSet :: IntSet -> [Int]
+ GHC.Cmm.LRegSet: elemsLRegSet :: Word64Set -> [Word64]
- GHC.Cmm.LRegSet: plusLRegSet :: IntSet -> IntSet -> IntSet
+ GHC.Cmm.LRegSet: plusLRegSet :: Word64Set -> Word64Set -> Word64Set
- GHC.Cmm.LRegSet: sizeLRegSet :: IntSet -> Int
+ GHC.Cmm.LRegSet: sizeLRegSet :: Word64Set -> Int
- GHC.Cmm.LRegSet: type LRegKey = Int
+ GHC.Cmm.LRegSet: type LRegKey = Word64
- GHC.Cmm.LRegSet: type LRegSet = IntSet
+ GHC.Cmm.LRegSet: type LRegSet = Word64Set
- GHC.CmmToAsm.CFG.Dominators: type Graph = IntMap IntSet
+ GHC.CmmToAsm.CFG.Dominators: type Graph = Word64Map Word64Set
- GHC.CmmToAsm.CFG.Dominators: type Node = Int
+ GHC.CmmToAsm.CFG.Dominators: type Node = Word64
- GHC.Runtime.Interpreter: EvalBreak :: Bool -> HValueRef -> Int -> Int -> RemoteRef (ResumeContext b) -> RemotePtr CostCentreStack -> EvalStatus_ a b
+ GHC.Runtime.Interpreter: EvalBreak :: Bool -> HValueRef -> Int -> String -> RemoteRef (ResumeContext b) -> RemotePtr CostCentreStack -> EvalStatus_ a b
Files
- compiler/GHC/ByteCode/Asm.hs +3/−4
- compiler/GHC/ByteCode/Instr.hs +3/−7
- compiler/GHC/Cmm/CommonBlockElim.hs +4/−1
- compiler/GHC/Cmm/Dominators.hs +16/−10
- compiler/GHC/Cmm/LRegSet.hs +15/−14
- compiler/GHC/Cmm/Sink.hs +4/−4
- compiler/GHC/CmmToAsm/CFG.hs +12/−7
- compiler/GHC/CmmToAsm/CFG/Dominators.hs +93/−70
- compiler/GHC/CmmToAsm/Wasm/Asm.hs +5/−5
- compiler/GHC/CmmToAsm/Wasm/FromCmm.hs +2/−2
- compiler/GHC/CmmToAsm/Wasm/Types.hs +3/−3
- compiler/GHC/CmmToLlvm/Base.hs +6/−6
- compiler/GHC/Core/Opt/Pipeline.hs +2/−2
- compiler/GHC/Driver/Main.hs +2/−2
- compiler/GHC/Driver/Make.hs +9/−7
- compiler/GHC/HsToCore/Breakpoints.hs +7/−5
- compiler/GHC/HsToCore/Foreign/JavaScript.hs +1/−1
- compiler/GHC/HsToCore/Match/Literal.hs +38/−37
- compiler/GHC/Linker/Deps.hs +5/−0
- compiler/GHC/Runtime/Eval.hs +4/−6
- compiler/GHC/Runtime/Interpreter.hs +7/−4
- compiler/GHC/Stg/Pipeline.hs +4/−4
- compiler/GHC/StgToByteCode.hs +8/−6
- compiler/GHC/StgToCmm/Ticky.hs +13/−13
- compiler/GHC/StgToJS/Deps.hs +11/−10
- compiler/GHC/StgToJS/Ids.hs +1/−1
- compiler/GHC/StgToJS/Symbols.hs +11/−2
- compiler/GHC/Tc/Deriv/Utils.hs +32/−31
- compiler/GHC/Tc/Gen/Foreign.hs +11/−10
- compiler/GHC/Tc/Utils/Instantiate.hs +7/−6
- compiler/GHC/Tc/Utils/Monad.hs +7/−7
- compiler/GHC/ThToHs.hs +2/−1
- compiler/GHC/Utils/Unique.hs +35/−0
- ghc-lib.cabal +17/−6
- ghc-lib/stage0/compiler/build/primop-strictness.hs-incl +1/−1
compiler/GHC/ByteCode/Asm.hs view
@@ -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) _)
compiler/GHC/ByteCode/Instr.hs view
@@ -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 "<cc>"- where mb_uniq = sdocOption sdocSuppressUniques $ \case- True -> text "<uniq>"- False -> ppr uniq-+ ppr (BRK_FUN index _mod_name _cc) = text "BRK_FUN" <+> ppr index <+> text "<module>" <+> text "<cc>" -- -----------------------------------------------------------------------------
compiler/GHC/Cmm/CommonBlockElim.hs view
@@ -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
compiler/GHC/Cmm/Dominators.hs view
@@ -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
compiler/GHC/Cmm/LRegSet.hs view
@@ -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
compiler/GHC/Cmm/Sink.hs view
@@ -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
compiler/GHC/CmmToAsm/CFG.hs view
@@ -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.
compiler/GHC/CmmToAsm/CFG/Dominators.hs view
@@ -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) -----------------------------------------------------------------------------
compiler/GHC/CmmToAsm/Wasm/Asm.hs view
@@ -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
compiler/GHC/CmmToAsm/Wasm/FromCmm.hs view
@@ -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 }
compiler/GHC/CmmToAsm/Wasm/Types.hs view
@@ -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,
compiler/GHC/CmmToLlvm/Base.hs view
@@ -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 }
compiler/GHC/Core/Opt/Pipeline.hs view
@@ -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')
compiler/GHC/Driver/Main.hs view
@@ -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)
compiler/GHC/Driver/Make.hs view
@@ -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
compiler/GHC/HsToCore/Breakpoints.hs view
@@ -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
compiler/GHC/HsToCore/Foreign/JavaScript.hs view
@@ -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"
compiler/GHC/HsToCore/Match/Literal.hs view
@@ -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.
compiler/GHC/Linker/Deps.hs view
@@ -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 #-}
compiler/GHC/Runtime/Eval.hs view
@@ -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)
compiler/GHC/Runtime/Interpreter.hs view
@@ -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)
compiler/GHC/Stg/Pipeline.hs view
@@ -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
compiler/GHC/StgToByteCode.hs view
@@ -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"
compiler/GHC/StgToCmm/Ticky.hs view
@@ -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'
compiler/GHC/StgToJS/Deps.hs view
@@ -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
compiler/GHC/StgToJS/Ids.hs view
@@ -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
compiler/GHC/StgToJS/Symbols.hs view
@@ -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
compiler/GHC/Tc/Deriv/Utils.hs view
@@ -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
compiler/GHC/Tc/Gen/Foreign.hs view
@@ -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
compiler/GHC/Tc/Utils/Instantiate.hs view
@@ -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
compiler/GHC/Tc/Utils/Monad.hs view
@@ -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
compiler/GHC/ThToHs.hs view
@@ -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 {-
+ compiler/GHC/Utils/Unique.hs view
@@ -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
ghc-lib.cabal view
@@ -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
ghc-lib/stage0/compiler/build/primop-strictness.hs-incl view
@@ -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