diff --git a/compiler/GHC.hs b/compiler/GHC.hs --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -1958,6 +1958,6 @@ mkApiErr dflags msg = GhcApiError (showSDoc dflags msg) -- -foreign import ccall unsafe "keepCAFsForGHCi" +foreign import ccall unsafe "ghc_lib_parser_keepCAFsForGHCi" c_keepCAFsForGHCi :: IO Bool 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 @@ -506,11 +505,11 @@ CCALL off m_addr i -> do np <- addr m_addr emit bci_CCALL [SmallOp 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 @@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- -- (c) The University of Glasgow 2002-2006 @@ -19,7 +18,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 +29,7 @@ import GHC.Stack.CCS (CostCentre) import GHC.Stg.Syntax +import Language.Haskell.Syntax.Module.Name (ModuleName) -- ---------------------------------------------------------------------------- -- Bytecode instructions @@ -202,7 +201,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 @@ -353,11 +352,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/Opt.hs b/compiler/GHC/Cmm/Opt.hs --- a/compiler/GHC/Cmm/Opt.hs +++ b/compiler/GHC/Cmm/Opt.hs @@ -213,23 +213,33 @@ = Just $! CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ] where off = fromIntegral (narrowS rep n) --- Make a RegOff if we can +-- Make a RegOff if we can. We don't perform this optimization if rep is greater +-- than the host word size because we use an Int to store the offset. See +-- #24893 and #24700. This should be fixed to ensure that optimizations don't +-- depend on the compiler host platform. cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)] + | validOffsetRep rep = Just $! cmmRegOff reg (fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] + | validOffsetRep rep = Just $! cmmRegOff reg (off + fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)] + | validOffsetRep rep = Just $! cmmRegOff reg (- fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] + | validOffsetRep rep = Just $! cmmRegOff reg (off - fromIntegral (narrowS rep n)) -- Fold label(+/-)offset into a CmmLit where possible cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)] + | validOffsetRep rep = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit] + | validOffsetRep rep = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)] + | validOffsetRep rep = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i)))) @@ -409,6 +419,13 @@ -- Anything else is just too hard. cmmMachOpFoldM _ _ _ = Nothing + +-- | Check that a literal width is compatible with the host word size used to +-- store offsets. This should be fixed properly (using larger types to store +-- literal offsets). See #24893 +validOffsetRep :: Width -> Bool +validOffsetRep rep = widthInBits rep <= finiteBitSize (undefined :: Int) + {- Note [Comparison operators] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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/AArch64/Instr.hs b/compiler/GHC/CmmToAsm/AArch64/Instr.hs --- a/compiler/GHC/CmmToAsm/AArch64/Instr.hs +++ b/compiler/GHC/CmmToAsm/AArch64/Instr.hs @@ -175,6 +175,8 @@ interesting _ (RegReal (RealRegSingle (-1))) = False interesting platform (RegReal (RealRegSingle i)) = freeReg platform i +-- Note [AArch64 Register assignments] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Save caller save registers -- This is x0-x18 -- @@ -197,6 +199,8 @@ -- '---------------------------------------------------------------------------------------------------------------------------------------------------------------' -- IR: Indirect result location register, IP: Intra-procedure register, PL: Platform register, FP: Frame pointer, LR: Link register, SP: Stack pointer -- BR: Base, SL: SpLim +-- +-- TODO: The zero register is currently mapped to -1 but should get it's own separate number. callerSavedRegisters :: [Reg] callerSavedRegisters = map regSingle [0..18] diff --git a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs --- a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs +++ b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs @@ -330,6 +330,7 @@ | w == W64 = text "sp" | w == W32 = text "wsp" + -- See Note [AArch64 Register assignments] ppr_reg_no w i | i < 0, w == W32 = text "wzr" | i < 0, w == W64 = text "xzr" diff --git a/compiler/GHC/CmmToAsm/AArch64/Regs.hs b/compiler/GHC/CmmToAsm/AArch64/Regs.hs --- a/compiler/GHC/CmmToAsm/AArch64/Regs.hs +++ b/compiler/GHC/CmmToAsm/AArch64/Regs.hs @@ -17,6 +17,7 @@ import GHC.Utils.Panic import GHC.Platform +-- TODO: Should this include the zero register? allMachRegNos :: [RegNo] allMachRegNos = [0..31] ++ [32..63] -- allocatableRegs is allMachRegNos with the fixed-use regs removed. 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/Reg/Graph/TrivColorable.hs b/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs --- a/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs @@ -179,7 +179,8 @@ ArchPPC -> 26 ArchPPC_64 _ -> 20 ArchARM _ _ _ -> panic "trivColorable ArchARM" - ArchAArch64 -> 32 + ArchAArch64 -> 24 -- 32 - F1 .. F4, D1..D4 - it's odd but see Note [AArch64 Register assignments] for our reg use. + -- Seems we reserve different registers for D1..D4 and F1 .. F4 somehow, we should fix this. ArchAlpha -> panic "trivColorable ArchAlpha" ArchMipseb -> panic "trivColorable ArchMipseb" ArchMipsel -> panic "trivColorable ArchMipsel" 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 @@ -1551,7 +1551,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 @@ -53,7 +53,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 @@ -198,7 +198,7 @@ type SymMap = UniqMap SymName -- | No need to remember the symbols. -type SymSet = IS.IntSet +type SymSet = WS.Word64Set type GlobalInfo = (SymName, SomeWasmType) @@ -428,7 +428,7 @@ WasmCodeGenState { wasmPlatform = platform, - defaultSyms = IS.empty, + defaultSyms = WS.empty, funcTypes = emptyUniqMap, funcBodies = emptyUniqMap, diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs --- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs @@ -2437,10 +2437,11 @@ -> [CmmFormal] -- ^ where to put the result -> [CmmActual] -- ^ arguments (of mixed type) -> NatM InstrBlock -genCCall32 addr conv dest_regs args = do +genCCall32 addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do config <- getConfig let platform = ncgPlatform config - prom_args = map (maybePromoteCArg platform W32) args + args_hints = zip args (argHints ++ repeat NoHint) + prom_args = map (maybePromoteCArg platform W32) args_hints -- If the size is smaller than the word, we widen things (see maybePromoteCArg) arg_size_bytes :: CmmType -> Int @@ -2594,10 +2595,11 @@ -> [CmmFormal] -- ^ where to put the result -> [CmmActual] -- ^ arguments (of mixed type) -> NatM InstrBlock -genCCall64 addr conv dest_regs args = do +genCCall64 addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do platform <- getPlatform -- load up the register arguments - let prom_args = map (maybePromoteCArg platform W32) args + let args_hints = zip args (argHints ++ repeat NoHint) + let prom_args = map (maybePromoteCArg platform W32) args_hints let load_args :: [CmmExpr] -> [Reg] -- int regs avail for args @@ -2835,9 +2837,11 @@ assign_code dest_regs) -maybePromoteCArg :: Platform -> Width -> CmmExpr -> CmmExpr -maybePromoteCArg platform wto arg - | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg] +maybePromoteCArg :: Platform -> Width -> (CmmExpr, ForeignHint) -> CmmExpr +maybePromoteCArg platform wto (arg, hint) + | wfrom < wto = case hint of + SignedHint -> CmmMachOp (MO_SS_Conv wfrom wto) [arg] + _ -> CmmMachOp (MO_UU_Conv wfrom wto) [arg] | otherwise = arg where wfrom = cmmExprWidth platform arg diff --git a/compiler/GHC/CmmToLlvm.hs b/compiler/GHC/CmmToLlvm.hs --- a/compiler/GHC/CmmToLlvm.hs +++ b/compiler/GHC/CmmToLlvm.hs @@ -11,7 +11,7 @@ ) where -import GHC.Prelude hiding ( head ) +import GHC.Prelude import GHC.Llvm import GHC.CmmToLlvm.Base @@ -28,7 +28,6 @@ import GHC.Utils.BufHandle import GHC.Driver.Session -import GHC.Platform ( platformArch, Arch(..) ) import GHC.Utils.Error import GHC.Data.FastString import GHC.Utils.Outputable @@ -37,8 +36,7 @@ import qualified GHC.Data.Stream as Stream import Control.Monad ( when, forM_ ) -import Data.List.NonEmpty ( head ) -import Data.Maybe ( fromMaybe, catMaybes ) +import Data.Maybe ( fromMaybe, catMaybes, isNothing ) import System.IO -- ----------------------------------------------------------------------------- @@ -68,11 +66,13 @@ "up to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "(non inclusive) is supported." <+> "System LLVM version: " <> text (llvmVersionStr ver) $$ "We will try though..." - let isS390X = platformArch (llvmCgPlatform cfg) == ArchS390X - let major_ver = head . llvmVersionNE $ ver - when (isS390X && major_ver < 10 && doWarn) $ putMsg logger $ - "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+> - "You are using LLVM version: " <> text (llvmVersionStr ver) + + when (isNothing mb_ver) $ do + let doWarn = llvmCgDoWarn cfg + when doWarn $ putMsg logger $ + "Failed to detect LLVM version!" $$ + "Make sure LLVM is installed correctly." $$ + "We will try though..." -- HACK: the Nothing case here is potentially wrong here but we -- currently don't use the LLVM version to guide code generation 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/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -675,13 +675,11 @@ -- type constructor via a .hs-boot file (#8743) , let dc = dcs `getNth` (con_tag - fIRST_TAG) , null (dataConExTyCoVars dc) -- no existentials; - -- See Note [Which types are unboxed?] + -- See (CPR1) in Note [Which types are unboxed?] -- and GHC.Core.Opt.CprAnal.argCprType -- where we also check this. - , all isLinear (dataConInstArgTys dc tc_args) - -- Deactivates CPR worker/wrapper splits on constructors with non-linear - -- arguments, for the moment, because they require unboxed tuple with variable - -- multiplicity fields. + , null (dataConTheta dc) -- no constraints; + -- See (CPR2) in Note [Which types are unboxed?] = DoUnbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args , dcpc_co = co, dcpc_args = arg_cprs }) @@ -692,13 +690,6 @@ -- See Note [non-algebraic or open body type warning] open_body_ty_warning = warnPprTrace True "canUnboxResult: non-algebraic or open body type" (ppr ty) Nothing -isLinear :: Scaled a -> Bool -isLinear (Scaled w _ ) = - case w of - OneTy -> True - _ -> False - - {- Note [Which types are unboxed?] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Worker/wrapper will unbox @@ -720,24 +711,27 @@ * is not recursive (as per 'isRecDataCon') * (might have multiple constructors, in contrast to (1)) * the applied data constructor *does not* bind existentials + * nor does it bind constraints (equalities or dictionaries) We can transform > f x y = let ... in D a b to > $wf x y = let ... in (# a, b #) via 'mkWWcpr'. - NB: We don't allow existentials for CPR W/W, because we don't have unboxed - dependent tuples (yet?). Otherwise, we could transform + (CPR1). We don't allow existentials for CPR W/W, because we don't have + unboxed dependent tuples (yet?). Otherwise, we could transform > f x y = let ... in D @ex (a :: ..ex..) (b :: ..ex..) to > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #) + (CPR2) we don't allow constraints for CPR W/W, because an unboxed tuple + contains types of kind `TYPE rr`, but not of kind `CONSTRAINT rr`. + This is annoying; there is no real reason for this except that we don't + have TYPE/CONSTAINT polymorphism. See Note [TYPE and CONSTRAINT] + in GHC.Builtin.Types.Prim. + The respective tests are in 'canUnboxArg' and 'canUnboxResult', respectively. - -Note that the data constructor /can/ have evidence arguments: equality -constraints, type classes etc. So it can be GADT. These evidence -arguments are simply value arguments, and should not get in the way. Note [mkWWstr and unsafeCoerce] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -1711,6 +1711,17 @@ It is also similar to Note [Do not strictify a DFun's parameter dictionaries], where marking recursive DFuns (of undecidable *instances*) strict in dictionary *parameters* leads to quite the same change in termination as above. + +Note [Controlling Speculative Evaluation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Most of the time, speculative evaluation has a positive effect on performance, +but we have found a case where speculative evaluation of dictionary functions +leads to a performance regression #25284. + +Therefore we have some flags to control it. See the optimization section in +the User's Guide for the description of these flags and when to use them. + -} data FloatingBind @@ -1785,7 +1796,15 @@ where is_hnf = exprIsHNF rhs is_strict = isStrUsedDmd dmd - ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs + cfg = cpe_config env + + ok_for_spec = exprOkForSpecEval call_ok_for_spec rhs + -- See Note [Controlling Speculative Evaluation] + call_ok_for_spec x + | is_rec_call x = False + | not (cp_specEval cfg) = False + | not (cp_specEvalDFun cfg) && isDFunId x = False + | otherwise = True is_rec_call = (`elemUnVarSet` cpe_rec_ids env) emptyFloats :: Floats @@ -1973,6 +1992,12 @@ , cp_convertNumLit :: !(LitNumType -> Integer -> Maybe CoreExpr) -- ^ Convert some numeric literals (Integer, Natural) into their final -- Core form. + + , cp_specEval :: !Bool + -- ^ Whether to perform speculative evaluation + -- See Note [Controlling Speculative Evaluation] + , cp_specEvalDFun :: !Bool + -- ^ Whether to perform speculative evaluation on DFuns } data CorePrepEnv diff --git a/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs b/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs --- a/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs +++ b/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs @@ -80,6 +80,7 @@ initGentleSimplMode dflags = (initSimplMode dflags InitialPhase "Gentle") { -- Don't do case-of-case transformations. -- This makes full laziness work better + -- See Note [Case-of-case and full laziness] sm_case_case = False } @@ -89,3 +90,37 @@ (True, True) -> FloatEnabled (True, False)-> FloatNestedOnly (False, _) -> FloatDisabled + + +{- Note [Case-of-case and full laziness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Case-of-case can hide opportunities for let-floating (full laziness). +For example + rec { f = \y. case (expensive x) of (a,b) -> blah } +We might hope to float the (expensive x) out of the \y-loop. +But if we inline `expensive` we might get + \y. case (case x of I# x' -> body) of (a,b) -> blah +Now if we do case-of-case we get + \y. case x if I# x2 -> + case body of (a,b) -> blah + +Sadly, at this point `body` mentions `x2`, so we can't float it out of the +\y-loop. + +Solution: don't do case-of-case in the "gentle" simplification phase that +precedes the first float-out transformation. Implementation: + + * `sm_case_case` field in SimplMode + + * Consult `sm_case_case` (via `seCaseCase`) before doing case-of-case + in GHC.Core.Opt.Simplify.Iteration.rebuildCall. + +Wrinkles + +* This applies equally to the case-of-runRW# transformation: + case (runRW# (\s. body)) of (a,b) -> blah + ---> + runRW# (\s. case body of (a,b) -> blah) + Again, don't do this when `sm_case_case` is off. See #25055 for + a motivating example. +-} diff --git a/compiler/GHC/Driver/Config/CoreToStg/Prep.hs b/compiler/GHC/Driver/Config/CoreToStg/Prep.hs --- a/compiler/GHC/Driver/Config/CoreToStg/Prep.hs +++ b/compiler/GHC/Driver/Config/CoreToStg/Prep.hs @@ -25,6 +25,8 @@ return $ CorePrepConfig { cp_catchNonexhaustiveCases = gopt Opt_CatchNonexhaustiveCases $ hsc_dflags hsc_env , cp_convertNumLit = convertNumLit + , cp_specEval = gopt Opt_SpecEval $ hsc_dflags hsc_env + , cp_specEvalDFun = gopt Opt_SpecEvalDictFun $ hsc_dflags hsc_env } initCorePrepPgmConfig :: DynFlags -> [Var] -> CorePrepPgmConfig 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 @@ -150,9 +150,9 @@ import GHC.Utils.Constants import GHC.Types.Unique.DFM (udfmRestrictKeysSet) import GHC.Types.Unique.Map -import qualified Data.IntSet as I import GHC.Types.Unique +import qualified GHC.Data.Word64Set as W -- ----------------------------------------------------------------------------- -- Loading the program @@ -337,10 +337,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) @@ -351,7 +353,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 @@ -2799,12 +2801,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) @@ -2815,7 +2817,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) @@ -2830,7 +2832,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/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -552,28 +552,28 @@ compileFile :: HscEnv -> StopPhase -> (FilePath, Maybe Phase) -> IO (Maybe FilePath) compileFile hsc_env stop_phase (src, mb_phase) = do - exists <- doesFileExist src - when (not exists) $ - throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src)) + let offset_file = augmentByWorkingDirectory dflags src + dflags = hsc_dflags hsc_env + mb_o_file = outputFile dflags + ghc_link = ghcLink dflags -- Set by -c or -no-link + notStopPreprocess | StopPreprocess <- stop_phase = False + | _ <- stop_phase = True + -- When linking, the -o argument refers to the linker's output. + -- otherwise, we use it as the name for the pipeline's output. + output + | not (backendGeneratesCode (backend dflags)), notStopPreprocess = NoOutputFile + -- avoid -E -fno-code undesirable interactions. see #20439 + | NoStop <- stop_phase, not (isNoLink ghc_link) = Persistent + -- -o foo applies to linker + | isJust mb_o_file = SpecificFile + -- -o foo applies to the file we are compiling now + | otherwise = Persistent + pipe_env = mkPipeEnv stop_phase offset_file mb_phase output + pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) offset_file mb_phase - let - dflags = hsc_dflags hsc_env - mb_o_file = outputFile dflags - ghc_link = ghcLink dflags -- Set by -c or -no-link - notStopPreprocess | StopPreprocess <- stop_phase = False - | _ <- stop_phase = True - -- When linking, the -o argument refers to the linker's output. - -- otherwise, we use it as the name for the pipeline's output. - output - | not (backendGeneratesCode (backend dflags)), notStopPreprocess = NoOutputFile - -- avoid -E -fno-code undesirable interactions. see #20439 - | NoStop <- stop_phase, not (isNoLink ghc_link) = Persistent - -- -o foo applies to linker - | isJust mb_o_file = SpecificFile - -- -o foo applies to the file we are compiling now - | otherwise = Persistent - pipe_env = mkPipeEnv stop_phase src mb_phase output - pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) src mb_phase + exists <- doesFileExist offset_file + when (not exists) $ + throwGhcExceptionIO (CmdLineError ("does not exist: " ++ offset_file)) runPipeline (hsc_hooks hsc_env) pipeline 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/C.hs b/compiler/GHC/HsToCore/Foreign/C.hs --- a/compiler/GHC/HsToCore/Foreign/C.hs +++ b/compiler/GHC/HsToCore/Foreign/C.hs @@ -401,17 +401,11 @@ Int -- total size of arguments ) mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc - = ( header_bits + = + ( header_bits , CStub body [] [] , type_string, - sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args - -- NB. the calculation here isn't strictly speaking correct. - -- We have a primitive Haskell type (eg. Int#, Double#), and - -- we want to know the size, when passed on the C stack, of - -- the associated C type (eg. HsInt, HsDouble). We don't have - -- this information to hand, but we know what GHC's conventions - -- are for passing around the primitive Haskell types, so we - -- use that instead. I hope the two coincide --SDM + aug_arg_size ) where platform = targetPlatform dflags @@ -450,6 +444,19 @@ | isNothing maybe_target = stable_ptr_arg : insertRetAddr platform cc arg_info | otherwise = arg_info + aug_arg_size = sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] + -- NB. the calculation here isn't strictly speaking correct. + -- We have a primitive Haskell type (eg. Int#, Double#), and + -- we want to know the size, when passed on the C stack, of + -- the associated C type (eg. HsInt, HsDouble). We don't have + -- this information to hand, but we know what GHC's conventions + -- are for passing around the primitive Haskell types, so we + -- use that instead. I hope the two coincide --SDM + -- AK: This seems just wrong, the code here uses widthInBytes, but when + -- we pass args on the haskell stack we always extend to multiples of 8 + -- to my knowledge. Not sure if it matters though so I won't touch this + -- for now. + stable_ptr_arg = (text "the_stableptr", text "StgStablePtr", undefined, typeCmmType platform (mkStablePtrPrimTy alphaTy)) @@ -605,8 +612,11 @@ -> [(SDoc, SDoc, Type, CmmType)] go 6 args = ret_addr_arg platform : args go n (arg@(_,_,_,rep):args) - | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args - | otherwise = arg : go n args + -- Int type fitting into int register + | (isBitsType rep && typeWidth rep <= W64 || isGcPtrType rep) + = arg : go (n+1) args + | otherwise + = arg : go n args go _ [] = [] in go 0 args _ -> 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 @@ -313,29 +314,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 () @@ -392,22 +393,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/Iface/Recomp/Flags.hs b/compiler/GHC/Iface/Recomp/Flags.hs --- a/compiler/GHC/Iface/Recomp/Flags.hs +++ b/compiler/GHC/Iface/Recomp/Flags.hs @@ -70,7 +70,10 @@ -- Other flags which affect code generation codegen = map (`gopt` dflags) (EnumSet.toList codeGenFlags) - flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, codegen, debugLevel, callerCcFilters)) + -- Did we include core for all bindings? + fat_iface = gopt Opt_WriteIfSimplifiedCore dflags + + flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, codegen, debugLevel, callerCcFilters, fat_iface)) in -- pprTrace "flags" (ppr flags) $ computeFingerprint nameio flags diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -615,8 +615,11 @@ getTyConImplicitBinds :: TyCon -> [CoreBind] getTyConImplicitBinds tc - | isNewTyCon tc = [] -- See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make - | otherwise = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) + | isDataTyCon tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) + | otherwise = [] + -- The 'otherwise' includes family TyCons of course, but also (less obviously) + -- * Newtypes: see Note [Compulsory newtype unfolding] in GHC.Types.Id.Make + -- * type data: we don't want any code for type-only stuff (#24620) getClassImplicitBinds :: Class -> [CoreBind] getClassImplicitBinds cls diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -2078,6 +2078,81 @@ (R5) There are no deriving clauses. +The data constructors of a `type data` declaration obey the following +Core invariant: + +(I1) The data constructors of a `type data` declaration may be mentioned in + /types/, but never in /terms/ or the /pattern of a case alternative/. + +Wrinkles: + +(W0) Wrappers. The data constructor of a `type data` declaration has a worker + (like every data constructor) but does /not/ have a wrapper. Wrappers + only make sense for value-level data constructors. Indeed, the worker Id + is never used (invariant (I1)), so it barely makes sense to talk about + the worker. A `type data` constructor only shows up in types, where it + appears as a TyCon, specifically a PromotedDataCon -- no Id in sight. + See #24620 for an example of what happens if you accidentally include + a wrapper. + + See `wrapped_reqd` in GHC.Types.Id.Make.mkDataConRep` for the place where + this check is implemented. + + This specifically includes `type data` declarations implemented as GADTs, + such as this example from #22948: + + type data T a where + A :: T Int + B :: T a + + If `T` were an ordinary `data` declaration, then `A` would have a wrapper + to account for the GADT-like equality in its return type. Because `T` is + declared as a `type data` declaration, however, the wrapper is omitted. + +(W1) To prevent users from conjuring up `type data` values at the term level, + we disallow using the tagToEnum# function on a type headed by a `type + data` type. For instance, GHC will reject this code: + + type data Letter = A | B | C + + f :: Letter + f = tagToEnum# 0# + + See `GHC.Tc.Gen.App.checkTagToEnum`, specifically `check_enumeration`. + +(W2) Although `type data` data constructors do not exist at the value level, + it is still possible to match on a value whose type is headed by a `type data` + type constructor, such as this example from #22964: + + type data T a where + A :: T Int + B :: T a + + f :: T a -> () + f x = case x of {} + + And yet we must guarantee invariant (I1). This has three consequences: + + (W2a) During checking the coverage of `f`'s pattern matches, we treat `T` + as if it were an empty data type so that GHC does not warn the user + to match against `A` or `B`. (Otherwise, you end up with the bug + reported in #22964.) See GHC.HsToCore.Pmc.Solver.vanillaCompleteMatchTC. + + (W2b) In `GHC.Core.Utils.refineDataAlt`, do /not/ fill in the DEFAULT case + with the data constructor, else (I1) is violated. See GHC.Core.Utils + Note [Refine DEFAULT case alternatives] Exception 2 + + (W2c) In `GHC.Core.Opt.ConstantFold.caseRules`, we do not want to transform + case dataToTagLarge# x of t -> blah + into + case x of { A -> ...; B -> .. } + because again that conjures up the type-level-only data constructors + `A` and `B` in a pattern, violating (I1) (#23023). + So we check for "type data" TyCons before applying this + transformation. (In practice, this doesn't matter because + we also refuse to solve DataToTag instances at types + corresponding to type data declarations. + The main parts of the implementation are: * (R0): The parser recognizes `type data` (but not `type newtype`). 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 @@ -324,15 +324,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 @@ -357,15 +356,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/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs --- a/compiler/GHC/Stg/Pipeline.hs +++ b/compiler/GHC/Stg/Pipeline.hs @@ -62,10 +62,10 @@ type StgCgInfos = NameEnv TagSig 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 @@ -390,7 +389,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) @@ -401,8 +399,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, Word16)] @@ -2283,8 +2285,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 Object.ExportedFun) -- ^ Unique Id -> Object.ExportedFun (only to other modules) + { ddcModule :: !(Word64Map Unit) -- ^ Unique Module -> Unit + , ddcId :: !(Word64Map Object.ExportedFun) -- ^ Unique Id -> Object.ExportedFun (only to other modules) , ddcOther :: !(Map OtherSymb Object.ExportedFun) } @@ -72,13 +73,20 @@ genDependencyData mod units = do -- [(blockindex, blockdeps, required, exported)] ds <- evalStateT (mapM (uncurry oneDep) blocks) - (DDC IM.empty IM.empty M.empty) + (DDC WM.empty WM.empty M.empty) return $ Object.Deps { depsModule = mod , depsRequired = IS.fromList [ n | (n, _, True, _) <- ds ] , depsHaskellExported = M.fromList $ (\(n,_,_,es) -> map (,n) es) =<< ds , depsBlocks = listArray (0, length blocks-1) (map (\(_,deps,_,_) -> deps) ds) } + -- XXX + -- return $ BlockInfo + -- { bi_module = mod + -- , bi_must_link = IS.fromList [ n | (n, _, True, _) <- ds ] + -- , bi_exports = M.fromList $ (\(n,_,_,es) -> map (,n) es) =<< ds + -- , bi_block_deps = listArray (0, length blocks-1) (map (\(_,deps,_,_) -> deps) ds) + -- } where -- Id -> Block unitIdExports :: UniqFM Id Int @@ -144,7 +152,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 +175,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 Object.ExportedFun lookupExternalFun mbIdKey od@(OtherSymb m idTxt) = do let mk = getKey . getUnique $ m @@ -175,17 +183,17 @@ exp_fun = Object.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/Literal.hs b/compiler/GHC/StgToJS/Literal.hs --- a/compiler/GHC/StgToJS/Literal.hs +++ b/compiler/GHC/StgToJS/Literal.hs @@ -20,6 +20,7 @@ import GHC.Data.FastString import GHC.Types.Literal import GHC.Types.Basic +import GHC.Types.RepType import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable @@ -92,7 +93,26 @@ LitDouble r -> return [ DoubleLit . SaneDouble . r2d $ r ] LitLabel name _size fod -> return [ LabelLit (fod == IsFunction) (mkRawSymbol True name) , IntLit 0 ] - l -> pprPanic "genStaticLit" (ppr l) + LitRubbish _ rep -> + let prim_reps = runtimeRepPrimRep (text "GHC.StgToJS.Literal.genStaticLit") rep + in case expectOnly "GHC.StgToJS.Literal.genStaticLit" prim_reps of -- Note [Post-unarisation invariants] + LiftedRep -> pure [ NullLit ] + UnliftedRep -> pure [ NullLit ] + VoidRep -> pure [ ] + AddrRep -> pure [ NullLit, IntLit 0 ] + IntRep -> pure [ IntLit 0 ] + Int8Rep -> pure [ IntLit 0 ] + Int16Rep -> pure [ IntLit 0 ] + Int32Rep -> pure [ IntLit 0 ] + Int64Rep -> pure [ IntLit 0, IntLit 0 ] + WordRep -> pure [ IntLit 0 ] + Word8Rep -> pure [ IntLit 0 ] + Word16Rep -> pure [ IntLit 0 ] + Word32Rep -> pure [ IntLit 0 ] + Word64Rep -> pure [ IntLit 0, IntLit 0 ] + FloatRep -> pure [ DoubleLit (SaneDouble 0) ] + DoubleRep -> pure [ DoubleLit (SaneDouble 0) ] + VecRep {} -> pprPanic "GHC.StgToJS.Literal.genStaticLit: LitRubbish(VecRep) isn't supported" (ppr rep) -- make an unsigned 32 bit number from this unsigned one, lower 32 bits toU32Expr :: Integer -> JExpr 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/StgToJS/Types.hs b/compiler/GHC/StgToJS/Types.hs --- a/compiler/GHC/StgToJS/Types.hs +++ b/compiler/GHC/StgToJS/Types.hs @@ -50,6 +50,7 @@ import Data.Typeable (Typeable) import GHC.Generics (Generic) import Control.DeepSeq +import Data.Word -- | A State monad over IO holding the generator state. type G = StateT GenState IO @@ -200,7 +201,7 @@ -- | Keys to differentiate Ident's in the ID Cache data IdKey - = IdKey !Int !Int !IdType + = IdKey !Word64 !Int !IdType deriving (Eq, Ord) -- | Some other symbol diff --git a/compiler/GHC/SysTools/Cpp.hs b/compiler/GHC/SysTools/Cpp.hs --- a/compiler/GHC/SysTools/Cpp.hs +++ b/compiler/GHC/SysTools/Cpp.hs @@ -199,11 +199,17 @@ -- | Find out path to @ghcversion.h@ file getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath getGhcVersionPathName dflags unit_env = do - candidates <- case ghcVersionFile dflags of - Just path -> return [path] - Nothing -> do - ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId]) - return (( "ghcversion.h") <$> collectIncludeDirs ps) + let candidates = case ghcVersionFile dflags of + -- the user has provided an explicit `ghcversion.h` file to use. + Just path -> [path] + -- otherwise, try to find it in the rts' include-dirs. + -- Note: only in the RTS include-dirs! not all preload units less we may + -- use a wrong file. See #25106 where a globally installed + -- /usr/include/ghcversion.h file was used instead of the one provided + -- by the rts. + Nothing -> case lookupUnitId (ue_units unit_env) rtsUnitId of + Nothing -> [] + Just info -> ( "ghcversion.h") <$> collectIncludeDirs [info] found <- filterM doesFileExist candidates case found of diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs --- a/compiler/GHC/SysTools/Tasks.hs +++ b/compiler/GHC/SysTools/Tasks.hs @@ -247,14 +247,17 @@ (pin, pout, perr, p) <- runInteractiveProcess pgm args' Nothing Nothing {- > llc -version - LLVM (http://llvm.org/): - LLVM version 3.5.2 + LLVM version 15.0.7 ... + OR + LLVM (http://llvm.org/): + LLVM version 14.0.6 -} hSetBinaryMode pout False - _ <- hGetLine pout - vline <- hGetLine pout - let mb_ver = parseLlvmVersion vline + line1 <- hGetLine pout + mb_ver <- case parseLlvmVersion line1 of + mb_ver@(Just _) -> return mb_ver + Nothing -> parseLlvmVersion <$> hGetLine pout -- Try the second line hClose pin hClose pout hClose perr 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/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -89,6 +89,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 @@ -841,17 +842,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 @@ -445,14 +445,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} } @@ -695,14 +695,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 @@ -2150,7 +2151,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/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.6.6.20240701 +version: 9.6.7.20250325 license: BSD-3-Clause license-file: LICENSE category: Development @@ -60,7 +60,8 @@ ghc-lib/stage0/lib ghc-lib/stage0/compiler/build compiler - ghc-options: -fno-safe-haskell + if impl(ghc >= 8.8.1) + ghc-options: -fno-safe-haskell if flag(threaded-rts) ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS cc-options: -DTHREADED_RTS @@ -91,8 +92,8 @@ stm, rts, hpc >= 0.6 && < 0.8, - ghc-lib-parser == 9.6.6.20240701 - build-tool-depends: alex:alex >= 3.1, happy:happy > 1.20 + ghc-lib-parser == 9.6.7.20250325 + build-tool-depends: alex:alex >= 3.1, happy:happy < 1.21 other-extensions: BangPatterns CPP @@ -243,6 +244,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, @@ -459,6 +467,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, @@ -480,6 +490,8 @@ GHC.Utils.Ppr.Colour, GHC.Utils.TmpFs, GHC.Utils.Trace, + GHC.Utils.Unique, + GHC.Utils.Word64, GHC.Version, GHCi.BinaryArray, GHCi.BreakArray, 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 @@ -9,7 +9,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 diff --git a/ghc-lib/stage0/lib/settings b/ghc-lib/stage0/lib/settings --- a/ghc-lib/stage0/lib/settings +++ b/ghc-lib/stage0/lib/settings @@ -1,11 +1,11 @@ [("GCC extra via C opts", "") -,("C compiler command", "/usr/bin/gcc") +,("C compiler command", "/usr/local/opt/ccache/libexec/gcc") ,("C compiler flags", "--target=x86_64-apple-darwin ") -,("C++ compiler command", "/usr/bin/g++") +,("C++ compiler command", "/usr/local/opt/ccache/libexec/g++") ,("C++ compiler flags", "--target=x86_64-apple-darwin ") ,("C compiler link flags", "--target=x86_64-apple-darwin -Wl,-no_fixup_chains -Wl,-no_warn_duplicate_libraries") ,("C compiler supports -no-pie", "NO") -,("Haskell CPP command", "/usr/bin/gcc") +,("Haskell CPP command", "/usr/local/opt/ccache/libexec/gcc") ,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs") ,("ld command", "ld") ,("ld flags", "")