ghc-lib 9.6.6.20240701 → 9.6.7.20250325
raw patch · 52 files changed
+640/−366 lines, 52 filesdep ~ghc-lib-parserPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: ghc-lib-parser
API changes (from Hackage documentation)
- GHC.CmmToAsm.CFG.Dominators: asGraph :: Tree Node -> Rooted
+ GHC: Opt_SpecEval :: GeneralFlag
+ GHC: Opt_SpecEvalDictFun :: GeneralFlag
+ GHC: [modBreaks_module] :: ModBreaks -> RemotePtr ModuleName
+ GHC.CmmToAsm.CFG.Dominators: asCGraph :: Tree Node -> Rooted
+ GHC.CoreToStg.Prep: [cp_specEvalDFun] :: CorePrepConfig -> !Bool
+ GHC.CoreToStg.Prep: [cp_specEval] :: CorePrepConfig -> !Bool
+ GHC.StgToJS.Symbols: word64BS :: Word64 -> ByteString
- 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 Int -> 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 -> 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 -> 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 -> 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 Int -> 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 -> 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 -> 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 -> 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.CoreToStg.Prep: CorePrepConfig :: !Bool -> !LitNumType -> Integer -> Maybe CoreExpr -> CorePrepConfig
+ GHC.CoreToStg.Prep: CorePrepConfig :: !Bool -> !LitNumType -> Integer -> Maybe CoreExpr -> !Bool -> !Bool -> CorePrepConfig
- GHC.StgToJS.Types: IdKey :: !Int -> !Int -> !IdType -> IdKey
+ GHC.StgToJS.Types: IdKey :: !Word64 -> !Int -> !IdType -> IdKey
Files
- compiler/GHC.hs +1/−1
- compiler/GHC/ByteCode/Asm.hs +3/−4
- compiler/GHC/ByteCode/Instr.hs +3/−8
- compiler/GHC/Cmm/CommonBlockElim.hs +4/−1
- compiler/GHC/Cmm/Dominators.hs +16/−10
- compiler/GHC/Cmm/LRegSet.hs +15/−14
- compiler/GHC/Cmm/Opt.hs +18/−1
- compiler/GHC/Cmm/Sink.hs +4/−4
- compiler/GHC/CmmToAsm/AArch64/Instr.hs +4/−0
- compiler/GHC/CmmToAsm/AArch64/Ppr.hs +1/−0
- compiler/GHC/CmmToAsm/AArch64/Regs.hs +1/−0
- compiler/GHC/CmmToAsm/CFG.hs +12/−7
- compiler/GHC/CmmToAsm/CFG/Dominators.hs +93/−70
- compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +2/−1
- 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/CmmToAsm/X86/CodeGen.hs +11/−7
- compiler/GHC/CmmToLlvm.hs +9/−9
- compiler/GHC/CmmToLlvm/Base.hs +6/−6
- compiler/GHC/Core/Opt/Pipeline.hs +2/−2
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs +12/−18
- compiler/GHC/CoreToStg/Prep.hs +26/−1
- compiler/GHC/Driver/Config/Core/Opt/Simplify.hs +35/−0
- compiler/GHC/Driver/Config/CoreToStg/Prep.hs +2/−0
- compiler/GHC/Driver/Make.hs +9/−7
- compiler/GHC/Driver/Pipeline.hs +21/−21
- compiler/GHC/HsToCore/Breakpoints.hs +7/−5
- compiler/GHC/HsToCore/Foreign/C.hs +21/−11
- compiler/GHC/HsToCore/Foreign/JavaScript.hs +1/−1
- compiler/GHC/HsToCore/Match/Literal.hs +38/−37
- compiler/GHC/Iface/Recomp/Flags.hs +4/−1
- compiler/GHC/Iface/Tidy.hs +5/−2
- compiler/GHC/Rename/Module.hs +75/−0
- compiler/GHC/Runtime/Eval.hs +4/−6
- 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 +18/−10
- compiler/GHC/StgToJS/Ids.hs +1/−1
- compiler/GHC/StgToJS/Literal.hs +21/−1
- compiler/GHC/StgToJS/Symbols.hs +11/−2
- compiler/GHC/StgToJS/Types.hs +2/−1
- compiler/GHC/SysTools/Cpp.hs +11/−5
- compiler/GHC/SysTools/Tasks.hs +8/−5
- compiler/GHC/Tc/Deriv/Utils.hs +32/−31
- compiler/GHC/Tc/Utils/Instantiate.hs +7/−6
- compiler/GHC/Tc/Utils/Monad.hs +7/−7
- compiler/GHC/ThToHs.hs +2/−1
- ghc-lib.cabal +16/−4
- ghc-lib/stage0/compiler/build/primop-strictness.hs-incl +1/−1
- ghc-lib/stage0/lib/settings +3/−3
compiler/GHC.hs view
@@ -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
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@@ -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) _)
compiler/GHC/ByteCode/Instr.hs view
@@ -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 "<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/Opt.hs view
@@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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/AArch64/Instr.hs view
@@ -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]
compiler/GHC/CmmToAsm/AArch64/Ppr.hs view
@@ -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"
compiler/GHC/CmmToAsm/AArch64/Regs.hs view
@@ -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.
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/Reg/Graph/TrivColorable.hs view
@@ -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"
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@@ -1551,7 +1551,7 @@ SymDefault -> wasmModifyM $ \s -> s { defaultSyms =- IS.insert+ WS.insert (getKey $ getUnique sym) $ defaultSyms s }
compiler/GHC/CmmToAsm/Wasm/Types.hs view
@@ -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,
compiler/GHC/CmmToAsm/X86/CodeGen.hs view
@@ -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
compiler/GHC/CmmToLlvm.hs view
@@ -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
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/Core/Opt/WorkWrap/Utils.hs view
@@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/CoreToStg/Prep.hs view
@@ -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
compiler/GHC/Driver/Config/Core/Opt/Simplify.hs view
@@ -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.+-}
compiler/GHC/Driver/Config/CoreToStg/Prep.hs view
@@ -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
compiler/GHC/Driver/Make.hs view
@@ -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
compiler/GHC/Driver/Pipeline.hs view
@@ -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
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/C.hs view
@@ -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 _ ->
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 @@ -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.
compiler/GHC/Iface/Recomp/Flags.hs view
@@ -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
compiler/GHC/Iface/Tidy.hs view
@@ -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
compiler/GHC/Rename/Module.hs view
@@ -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`).
compiler/GHC/Runtime/Eval.hs view
@@ -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)
compiler/GHC/Stg/Pipeline.hs view
@@ -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
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@@ -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"
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 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
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/Literal.hs view
@@ -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
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/StgToJS/Types.hs view
@@ -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
compiler/GHC/SysTools/Cpp.hs view
@@ -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
compiler/GHC/SysTools/Tasks.hs view
@@ -247,14 +247,17 @@ (pin, pout, perr, p) <- runInteractiveProcess pgm args' Nothing Nothing {- > llc -version- LLVM (http://llvm.org/):- LLVM version 3.5.2+ <vendor> 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
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/Utils/Instantiate.hs view
@@ -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
compiler/GHC/Tc/Utils/Monad.hs view
@@ -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
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@@ -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 {-
ghc-lib.cabal view
@@ -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,
ghc-lib/stage0/compiler/build/primop-strictness.hs-incl view
@@ -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
ghc-lib/stage0/lib/settings view
@@ -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", "")