[Git][ghc/ghc][wip/T22010] Word64 Unique; compiles but some TODOs left
Jaro Reinders (@Noughtmare)
gitlab at gitlab.haskell.org
Fri Jun 2 08:30:56 UTC 2023
Jaro Reinders pushed to branch wip/T22010 at Glasgow Haskell Compiler / GHC
Commits:
f83f8b41 by Jaro Reinders at 2023-06-02T10:30:36+02:00
Word64 Unique; compiles but some TODOs left
- - - - -
25 changed files:
- compiler/GHC/Cmm/Sink.hs
- compiler/GHC/CmmToAsm/Wasm/Asm.hs
- compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
- compiler/GHC/CmmToAsm/Wasm/Types.hs
- − compiler/GHC/Data/Word64Map/Internal/Debug.hs
- − compiler/GHC/Data/Word64Map/Merge/Lazy.hs
- − compiler/GHC/Data/Word64Map/Merge/Strict.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/HsToCore/Foreign/JavaScript.hs
- compiler/GHC/StgToJS/Deps.hs
- compiler/GHC/StgToJS/Ids.hs
- compiler/GHC/StgToJS/Symbols.hs
- compiler/GHC/StgToJS/Types.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/Unique/Supply.hs
- compiler/GHC/Types/Var/Env.hs
- − compiler/GHC/Utils/Containers/Internal/BitQueue.hs
- − compiler/GHC/Utils/Containers/Internal/Coercions.hs
- − compiler/GHC/Utils/Containers/Internal/PtrEquality.hs
- − compiler/GHC/Utils/Containers/Internal/State.hs
- − compiler/GHC/Utils/Containers/Internal/StrictMaybe.hs
- − compiler/GHC/Utils/Containers/Internal/TypeError.hs
- compiler/ghc.cabal.in
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
Changes:
=====================================
compiler/GHC/Cmm/Sink.hs
=====================================
@@ -22,6 +22,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 +176,7 @@ cmmSink platform graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
-- 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 +189,7 @@ cmmSink platform graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
-- 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 +216,7 @@ cmmSink platform graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
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/Wasm/Asm.hs
=====================================
@@ -15,6 +15,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 +182,9 @@ asmTellSectionHeader :: Builder -> WasmAsmM ()
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 +421,12 @@ asmTellWasmControl ty_word c = case c of
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
=====================================
@@ -27,6 +27,7 @@ import qualified Data.ByteString as BS
import Data.Foldable
import Data.Functor
import qualified Data.IntSet as IS
+import qualified GHC.Data.Word64Set as WS
import Data.Semigroup
import Data.String
import Data.Traversable
@@ -1553,7 +1554,7 @@ onTopSym lbl = case sym_vis of
SymDefault -> wasmModifyM $ \s ->
s
{ defaultSyms =
- IS.insert
+ WS.insert
(getKey $ getUnique sym)
$ defaultSyms s
}
=====================================
compiler/GHC/CmmToAsm/Wasm/Types.hs
=====================================
@@ -53,6 +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
@@ -197,7 +198,7 @@ data DataSection = DataSection
type SymMap = UniqMap SymName
-- | No need to remember the symbols.
-type SymSet = IS.IntSet
+type SymSet = WS.Word64Set
type GlobalInfo = (SymName, SomeWasmType)
@@ -427,7 +428,7 @@ initialWasmCodeGenState platform us =
WasmCodeGenState
{ wasmPlatform =
platform,
- defaultSyms = IS.empty,
+ defaultSyms = WS.empty,
funcTypes = emptyUniqMap,
funcBodies =
emptyUniqMap,
=====================================
compiler/GHC/Data/Word64Map/Internal/Debug.hs deleted
=====================================
@@ -1,6 +0,0 @@
-module GHC.Data.Word64Map.Internal.Debug
- ( showTree
- , showTreeWith
- ) where
-
-import GHC.Data.Word64Map.Internal
=====================================
compiler/GHC/Data/Word64Map/Merge/Lazy.hs deleted
=====================================
@@ -1,91 +0,0 @@
-{-# LANGUAGE CPP #-}
-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)
-{-# LANGUAGE Safe #-}
-#endif
-
-#include "containers.h"
-
------------------------------------------------------------------------------
--- |
--- Module : Data.IntMap.Merge.Lazy
--- Copyright : (c) wren romano 2016
--- License : BSD-style
--- Maintainer : libraries at haskell.org
--- Portability : portable
---
--- This module defines an API for writing functions that merge two
--- maps. The key functions are 'merge' and 'mergeA'.
--- Each of these can be used with several different \"merge tactics\".
---
--- The 'merge' and 'mergeA' functions are shared by
--- the lazy and strict modules. Only the choice of merge tactics
--- determines strictness. If you use 'Data.Map.Merge.Strict.mapMissing'
--- from "Data.Map.Merge.Strict" then the results will be forced before
--- they are inserted. If you use 'Data.Map.Merge.Lazy.mapMissing' from
--- this module then they will not.
---
--- == Efficiency note
---
--- The 'Control.Category.Category', 'Applicative', and 'Monad' instances for
--- 'WhenMissing' tactics are included because they are valid. However, they are
--- inefficient in many cases and should usually be avoided. The instances
--- for 'WhenMatched' tactics should not pose any major efficiency problems.
---
--- @since 0.5.9
-
-module GHC.Data.Int64Map.Merge.Lazy (
- -- ** Simple merge tactic types
- SimpleWhenMissing
- , SimpleWhenMatched
-
- -- ** General combining function
- , merge
-
- -- *** @WhenMatched@ tactics
- , zipWithMaybeMatched
- , zipWithMatched
-
- -- *** @WhenMissing@ tactics
- , mapMaybeMissing
- , dropMissing
- , preserveMissing
- , mapMissing
- , filterMissing
-
- -- ** Applicative merge tactic types
- , WhenMissing
- , WhenMatched
-
- -- ** Applicative general combining function
- , mergeA
-
- -- *** @WhenMatched@ tactics
- -- | The tactics described for 'merge' work for
- -- 'mergeA' as well. Furthermore, the following
- -- are available.
- , zipWithMaybeAMatched
- , zipWithAMatched
-
- -- *** @WhenMissing@ tactics
- -- | The tactics described for 'merge' work for
- -- 'mergeA' as well. Furthermore, the following
- -- are available.
- , traverseMaybeMissing
- , traverseMissing
- , filterAMissing
-
- -- *** Covariant maps for tactics
- , mapWhenMissing
- , mapWhenMatched
-
- -- *** Contravariant maps for tactics
- , lmapWhenMissing
- , contramapFirstWhenMatched
- , contramapSecondWhenMatched
-
- -- *** Miscellaneous tactic functions
- , runWhenMatched
- , runWhenMissing
- ) where
-
-import Data.IntMap.Internal
=====================================
compiler/GHC/Data/Word64Map/Merge/Strict.hs deleted
=====================================
@@ -1,218 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE BangPatterns #-}
-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)
-{-# LANGUAGE Trustworthy #-}
-#endif
-
-#include "containers.h"
-
------------------------------------------------------------------------------
--- |
--- Module : Data.IntMap.Merge.Strict
--- Copyright : (c) wren romano 2016
--- License : BSD-style
--- Maintainer : libraries at haskell.org
--- Portability : portable
---
--- This module defines an API for writing functions that merge two
--- maps. The key functions are 'merge' and 'mergeA'.
--- Each of these can be used with several different \"merge tactics\".
---
--- The 'merge' and 'mergeA' functions are shared by
--- the lazy and strict modules. Only the choice of merge tactics
--- determines strictness. If you use 'Data.Map.Merge.Strict.mapMissing'
--- from this module then the results will be forced before they are
--- inserted. If you use 'Data.Map.Merge.Lazy.mapMissing' from
--- "Data.Map.Merge.Lazy" then they will not.
---
--- == Efficiency note
---
--- The 'Control.Category.Category', 'Applicative', and 'Monad' instances for
--- 'WhenMissing' tactics are included because they are valid. However, they are
--- inefficient in many cases and should usually be avoided. The instances
--- for 'WhenMatched' tactics should not pose any major efficiency problems.
---
--- @since 0.5.9
-
-module GHC.Data.Int64Map.Merge.Strict (
- -- ** Simple merge tactic types
- SimpleWhenMissing
- , SimpleWhenMatched
-
- -- ** General combining function
- , merge
-
- -- *** @WhenMatched@ tactics
- , zipWithMaybeMatched
- , zipWithMatched
-
- -- *** @WhenMissing@ tactics
- , mapMaybeMissing
- , dropMissing
- , preserveMissing
- , mapMissing
- , filterMissing
-
- -- ** Applicative merge tactic types
- , WhenMissing
- , WhenMatched
-
- -- ** Applicative general combining function
- , mergeA
-
- -- *** @WhenMatched@ tactics
- -- | The tactics described for 'merge' work for
- -- 'mergeA' as well. Furthermore, the following
- -- are available.
- , zipWithMaybeAMatched
- , zipWithAMatched
-
- -- *** @WhenMissing@ tactics
- -- | The tactics described for 'merge' work for
- -- 'mergeA' as well. Furthermore, the following
- -- are available.
- , traverseMaybeMissing
- , traverseMissing
- , filterAMissing
-
- -- ** Covariant maps for tactics
- , mapWhenMissing
- , mapWhenMatched
-
- -- ** Miscellaneous functions on tactics
-
- , runWhenMatched
- , runWhenMissing
- ) where
-
-import Data.IntMap.Internal
- ( SimpleWhenMissing
- , SimpleWhenMatched
- , merge
- , dropMissing
- , preserveMissing
- , filterMissing
- , WhenMissing (..)
- , WhenMatched (..)
- , mergeA
- , filterAMissing
- , runWhenMatched
- , runWhenMissing
- )
-import Data.IntMap.Strict.Internal
-import Prelude hiding (filter, map, foldl, foldr)
-
--- | Map covariantly over a @'WhenMissing' f k x at .
-mapWhenMissing :: Functor f => (a -> b) -> WhenMissing f x a -> WhenMissing f x b
-mapWhenMissing f q = WhenMissing
- { missingSubtree = fmap (map f) . missingSubtree q
- , missingKey = \k x -> fmap (forceMaybe . fmap f) $ missingKey q k x}
-
--- | Map covariantly over a @'WhenMatched' f k x y at .
-mapWhenMatched :: Functor f => (a -> b) -> WhenMatched f x y a -> WhenMatched f x y b
-mapWhenMatched f q = WhenMatched
- { matchedKey = \k x y -> fmap (forceMaybe . fmap f) $ runWhenMatched q k x y }
-
--- | When a key is found in both maps, apply a function to the
--- key and values and maybe use the result in the merged map.
---
--- @
--- zipWithMaybeMatched :: (k -> x -> y -> Maybe z)
--- -> SimpleWhenMatched k x y z
--- @
-zipWithMaybeMatched :: Applicative f
- => (Key -> x -> y -> Maybe z)
- -> WhenMatched f x y z
-zipWithMaybeMatched f = WhenMatched $
- \k x y -> pure $! forceMaybe $! f k x y
-{-# INLINE zipWithMaybeMatched #-}
-
--- | When a key is found in both maps, apply a function to the
--- key and values, perform the resulting action, and maybe use
--- the result in the merged map.
---
--- This is the fundamental 'WhenMatched' tactic.
-zipWithMaybeAMatched :: Applicative f
- => (Key -> x -> y -> f (Maybe z))
- -> WhenMatched f x y z
-zipWithMaybeAMatched f = WhenMatched $
- \ k x y -> forceMaybe <$> f k x y
-{-# INLINE zipWithMaybeAMatched #-}
-
--- | When a key is found in both maps, apply a function to the
--- key and values to produce an action and use its result in the merged map.
-zipWithAMatched :: Applicative f
- => (Key -> x -> y -> f z)
- -> WhenMatched f x y z
-zipWithAMatched f = WhenMatched $
- \ k x y -> (Just $!) <$> f k x y
-{-# INLINE zipWithAMatched #-}
-
--- | When a key is found in both maps, apply a function to the
--- key and values and use the result in the merged map.
---
--- @
--- zipWithMatched :: (k -> x -> y -> z)
--- -> SimpleWhenMatched k x y z
--- @
-zipWithMatched :: Applicative f
- => (Key -> x -> y -> z) -> WhenMatched f x y z
-zipWithMatched f = WhenMatched $
- \k x y -> pure $! Just $! f k x y
-{-# INLINE zipWithMatched #-}
-
--- | Map over the entries whose keys are missing from the other map,
--- optionally removing some. This is the most powerful 'SimpleWhenMissing'
--- tactic, but others are usually more efficient.
---
--- @
--- mapMaybeMissing :: (k -> x -> Maybe y) -> SimpleWhenMissing k x y
--- @
---
--- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x))
---
--- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations.
-mapMaybeMissing :: Applicative f => (Key -> x -> Maybe y) -> WhenMissing f x y
-mapMaybeMissing f = WhenMissing
- { missingSubtree = \m -> pure $! mapMaybeWithKey f m
- , missingKey = \k x -> pure $! forceMaybe $! f k x }
-{-# INLINE mapMaybeMissing #-}
-
--- | Map over the entries whose keys are missing from the other map.
---
--- @
--- mapMissing :: (k -> x -> y) -> SimpleWhenMissing k x y
--- @
---
--- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x)
---
--- but @mapMissing@ is somewhat faster.
-mapMissing :: Applicative f => (Key -> x -> y) -> WhenMissing f x y
-mapMissing f = WhenMissing
- { missingSubtree = \m -> pure $! mapWithKey f m
- , missingKey = \k x -> pure $! Just $! f k x }
-{-# INLINE mapMissing #-}
-
--- | Traverse over the entries whose keys are missing from the other map,
--- optionally producing values to put in the result.
--- This is the most powerful 'WhenMissing' tactic, but others are usually
--- more efficient.
-traverseMaybeMissing :: Applicative f
- => (Key -> x -> f (Maybe y)) -> WhenMissing f x y
-traverseMaybeMissing f = WhenMissing
- { missingSubtree = traverseMaybeWithKey f
- , missingKey = \k x -> forceMaybe <$> f k x }
-{-# INLINE traverseMaybeMissing #-}
-
--- | Traverse over the entries whose keys are missing from the other map.
-traverseMissing :: Applicative f
- => (Key -> x -> f y) -> WhenMissing f x y
-traverseMissing f = WhenMissing
- { missingSubtree = traverseWithKey f
- , missingKey = \k x -> (Just $!) <$> f k x }
-{-# INLINE traverseMissing #-}
-
-forceMaybe :: Maybe a -> Maybe a
-forceMaybe Nothing = Nothing
-forceMaybe m@(Just !_) = m
-{-# INLINE forceMaybe #-}
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -156,6 +156,7 @@ import GHC.Types.Unique
import GHC.Iface.Errors.Types
import qualified Data.IntSet as I
+import qualified GHC.Data.Word64Set as W
-- -----------------------------------------------------------------------------
-- Loading the program
@@ -2821,12 +2822,12 @@ See test "jspace" for an example which used to trigger this problem.
-}
-- 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)
@@ -2837,7 +2838,7 @@ wait_deps_hug hug_var deps = do
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)
@@ -2852,7 +2853,7 @@ wait_deps (x:xs) = do
Nothing -> return (hmis, new_deps)
Just hmi -> return (hmi:hmis, new_deps)
where
- unionModuleNameSet = M.unionWith I.union
+ unionModuleNameSet = M.unionWith W.union
-- Executing the pipelines
=====================================
compiler/GHC/HsToCore/Foreign/JavaScript.hs
=====================================
@@ -156,7 +156,7 @@ mkFExportJSBits platform c_nm maybe_target arg_htys res_hty is_IO_res_ty _cconv
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 <> word (fromIntegral u))
fun_args
| null arg_info = empty -- text "void"
=====================================
compiler/GHC/StgToJS/Deps.hs
=====================================
@@ -45,18 +45,19 @@ import Data.Map (Map)
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,7 +73,7 @@ genDependencyData
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 ]
@@ -144,7 +145,7 @@ genDependencyData mod units = do
in if m == mod
then pprPanic "local id not found" (ppr m)
else Left <$> do
- mr <- gets (IM.lookup k . ddcId)
+ mr <- gets (WM.lookup k . ddcId)
maybe addEntry return mr
-- get the function for an OtherSymb from the cache, add it if necessary
@@ -167,7 +168,7 @@ genDependencyData mod units = do
-- 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 +176,17 @@ genDependencyData mod units = do
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
=====================================
@@ -61,16 +61,18 @@ import qualified Control.Monad.Trans.State.Strict as State
import qualified Data.Map as M
import Data.Maybe
import qualified Data.ByteString.Char8 as BSC
+import Data.Word
-- | Get fresh unique number
-freshUnique :: G Int
+freshUnique :: G Word64
freshUnique = do
id_gen <- State.gets gsId
liftIO $ do
-- no need for atomicFetchAdd as we don't use threads in G
v <- readFastMutInt id_gen
writeFastMutInt id_gen (v+1)
- pure v
+ -- TODO: depends on readFastMutWord64
+ pure (undefined v)
-- | Get fresh local Ident of the form: h$$unit:module_uniq
freshIdent :: G Ident
@@ -131,7 +133,7 @@ makeIdentForId i num id_type current_module = TxtI ident
, 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
@@ -182,7 +184,7 @@ identsForId :: Id -> G [Ident]
identsForId i = case typeSize (idType i) of
0 -> pure mempty
1 -> (:[]) <$> identForId i
- s -> mapM (identForIdN i) [1..s]
+ s -> mapM (identForIdN i) [1 .. fromIntegral s]
-- | Retrieve entry Ident for the given Id
=====================================
compiler/GHC/StgToJS/Symbols.hs
=====================================
@@ -8,6 +8,7 @@ module GHC.StgToJS.Symbols
, mkFreshJsSymbol
, mkRawSymbol
, intBS
+ , word64BS
) where
import GHC.Prelude
@@ -15,16 +16,23 @@ import GHC.Prelude
import GHC.Data.FastString
import GHC.Unit.Module
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 . fromIntegral
+
+-- | 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
@@ -66,12 +74,12 @@ mkJsSymbol :: Bool -> Module -> FastString -> FastString
mkJsSymbol exported mod s = mkFastStringByteString (mkJsSymbolBS exported mod s)
-- | Make JS symbol for given module and unique.
-mkFreshJsSymbol :: Module -> Int -> FastString
+mkFreshJsSymbol :: Module -> Word64 -> FastString
mkFreshJsSymbol mod i = mkFastStringByteString $ mconcat
[ hdd
, unitModuleStringZ mod
, BSC.pack "_"
- , intBS i
+ , word64BS i
]
-- | Make symbol "h$XYZ" or "h$$XYZ"
=====================================
compiler/GHC/StgToJS/Types.hs
=====================================
@@ -49,6 +49,7 @@ import Data.Set (Set)
import qualified Data.ByteString as BS
import Data.Monoid
import Data.Typeable (Typeable)
+import Data.Word
import GHC.Generics (Generic)
import Control.DeepSeq
@@ -202,7 +203,7 @@ data IdType
-- | 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/ThToHs.hs
=====================================
@@ -63,6 +63,7 @@ import Data.Foldable (for_)
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
@@ -2192,7 +2193,7 @@ mk_mod mod = mkModuleName (TH.modString mod)
mk_pkg :: TH.PkgName -> Unit
mk_pkg pkg = stringToUnit (TH.pkgString pkg)
-mk_uniq :: Int -> Unique
+mk_uniq :: Word64 -> Unique
mk_uniq u = mkUniqueGrimily u
{-
=====================================
compiler/GHC/Types/Unique/Supply.hs
=====================================
@@ -40,6 +40,7 @@ import GHC.IO
import GHC.Utils.Monad
import Control.Monad
import Data.Char
+import Data.Word
import GHC.Exts( Ptr(..), noDuplicate#, oneShot )
#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
import GHC.Exts( Int(..), word2Int#, fetchAddWordAddr#, plusWord#, readWordOffAddr# )
@@ -184,7 +185,7 @@ optimizations to be used. So it seems safe to depend on this fact.
-- also manufacture an arbitrary number of further 'UniqueSupply' values,
-- which will be distinct from the first and from all others.
data UniqSupply
- = MkSplitUniqSupply {-# UNPACK #-} !Int -- make the Unique with this
+ = MkSplitUniqSupply {-# UNPACK #-} !Word64 -- make the Unique with this
UniqSupply UniqSupply
-- when split => these two supplies
@@ -206,7 +207,7 @@ mkSplitUniqSupply c
= unsafeDupableInterleaveIO (IO mk_supply)
where
- !mask = ord c `unsafeShiftL` uNIQUE_BITS
+ !mask = fromIntegral (ord c) `unsafeShiftL` uNIQUE_BITS
-- Here comes THE MAGIC: see Note [How the unique supply works]
-- This is one of the most hammered bits in the whole compiler
@@ -218,7 +219,8 @@ mkSplitUniqSupply c
-- deferred IO computations
case unIO (unsafeDupableInterleaveIO (IO mk_supply)) s2 of { (# s3, x #) ->
case unIO (unsafeDupableInterleaveIO (IO mk_supply)) s3 of { (# s4, y #) ->
- (# s4, MkSplitUniqSupply (mask .|. u) x y #)
+ -- FIXME: fill in the undefined
+ (# s4, MkSplitUniqSupply (mask .|. undefined u) x y #)
}}}}
#if !MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
=====================================
compiler/GHC/Types/Var/Env.hs
=====================================
@@ -79,6 +79,7 @@ module GHC.Types.Var.Env (
import GHC.Prelude
import qualified Data.IntMap.Strict as IntMap -- TODO: Move this to UniqFM
+import qualified GHC.Data.Word64Map.Strict as Word64Map -- TODO: Move this to UniqFM
import GHC.Types.Name.Occurrence
import GHC.Types.Name
@@ -228,7 +229,7 @@ uniqAway' in_scope var
-- introduce non-unique 'Unique's this way. See Note [Local uniques].
unsafeGetFreshLocalUnique :: InScopeSet -> Unique
unsafeGetFreshLocalUnique (InScope set)
- | Just (uniq,_) <- IntMap.lookupLT (getKey maxLocalUnique) (ufmToIntMap $ getUniqSet set)
+ | Just (uniq,_) <- Word64Map.lookupLT (getKey maxLocalUnique) (ufmToIntMap $ getUniqSet set)
, let uniq' = mkLocalUnique uniq
, not $ uniq' `ltUnique` minLocalUnique
= incrUnique uniq'
=====================================
compiler/GHC/Utils/Containers/Internal/BitQueue.hs deleted
=====================================
@@ -1,121 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE BangPatterns #-}
-
-#include "containers.h"
-
------------------------------------------------------------------------------
--- |
--- Module : Utils.Containers.Internal.BitQueue
--- Copyright : (c) David Feuer 2016
--- License : BSD-style
--- Maintainer : libraries at haskell.org
--- Portability : portable
---
--- = WARNING
---
--- This module is considered __internal__.
---
--- The Package Versioning Policy __does not apply__.
---
--- The contents of this module may change __in any way whatsoever__
--- and __without any warning__ between minor versions of this package.
---
--- Authors importing this module are expected to track development
--- closely.
---
--- = Description
---
--- An extremely light-weight, fast, and limited representation of a string of
--- up to (2*WORDSIZE - 2) bits. In fact, there are two representations,
--- misleadingly named bit queue builder and bit queue. The builder supports
--- only `emptyQB`, creating an empty builder, and `snocQB`, enqueueing a bit.
--- The bit queue builder is then turned into a bit queue using `buildQ`, after
--- which bits can be removed one by one using `unconsQ`. If the size limit is
--- exceeded, further operations will silently produce nonsense.
------------------------------------------------------------------------------
-
-module Utils.Containers.Internal.BitQueue
- ( BitQueue
- , BitQueueB
- , emptyQB
- , snocQB
- , buildQ
- , unconsQ
- , toListQ
- ) where
-
-import Utils.Containers.Internal.BitUtil (shiftLL, shiftRL, wordSize)
-import Data.Bits ((.|.), (.&.), testBit)
-import Data.Bits (countTrailingZeros)
-
--- A bit queue builder. We represent a double word using two words
--- because we don't currently have access to proper double words.
-data BitQueueB = BQB {-# UNPACK #-} !Word
- {-# UNPACK #-} !Word
-
-newtype BitQueue = BQ BitQueueB deriving Show
-
--- Intended for debugging.
-instance Show BitQueueB where
- show (BQB hi lo) = "BQ"++
- show (map (testBit hi) [(wordSize - 1),(wordSize - 2)..0]
- ++ map (testBit lo) [(wordSize - 1),(wordSize - 2)..0])
-
--- | Create an empty bit queue builder. This is represented as a single guard
--- bit in the most significant position.
-emptyQB :: BitQueueB
-emptyQB = BQB (1 `shiftLL` (wordSize - 1)) 0
-{-# INLINE emptyQB #-}
-
--- Shift the double word to the right by one bit.
-shiftQBR1 :: BitQueueB -> BitQueueB
-shiftQBR1 (BQB hi lo) = BQB hi' lo' where
- lo' = (lo `shiftRL` 1) .|. (hi `shiftLL` (wordSize - 1))
- hi' = hi `shiftRL` 1
-{-# INLINE shiftQBR1 #-}
-
--- | Enqueue a bit. This works by shifting the queue right one bit,
--- then setting the most significant bit as requested.
-{-# INLINE snocQB #-}
-snocQB :: BitQueueB -> Bool -> BitQueueB
-snocQB bq b = case shiftQBR1 bq of
- BQB hi lo -> BQB (hi .|. (fromIntegral (fromEnum b) `shiftLL` (wordSize - 1))) lo
-
--- | Convert a bit queue builder to a bit queue. This shifts in a new
--- guard bit on the left, and shifts right until the old guard bit falls
--- off.
-{-# INLINE buildQ #-}
-buildQ :: BitQueueB -> BitQueue
-buildQ (BQB hi 0) = BQ (BQB 0 lo') where
- zeros = countTrailingZeros hi
- lo' = ((hi `shiftRL` 1) .|. (1 `shiftLL` (wordSize - 1))) `shiftRL` zeros
-buildQ (BQB hi lo) = BQ (BQB hi' lo') where
- zeros = countTrailingZeros lo
- lo1 = (lo `shiftRL` 1) .|. (hi `shiftLL` (wordSize - 1))
- hi1 = (hi `shiftRL` 1) .|. (1 `shiftLL` (wordSize - 1))
- lo' = (lo1 `shiftRL` zeros) .|. (hi1 `shiftLL` (wordSize - zeros))
- hi' = hi1 `shiftRL` zeros
-
--- Test if the queue is empty, which occurs when there's
--- nothing left but a guard bit in the least significant
--- place.
-nullQ :: BitQueue -> Bool
-nullQ (BQ (BQB 0 1)) = True
-nullQ _ = False
-{-# INLINE nullQ #-}
-
--- | Dequeue an element, or discover the queue is empty.
-unconsQ :: BitQueue -> Maybe (Bool, BitQueue)
-unconsQ q | nullQ q = Nothing
-unconsQ (BQ bq@(BQB _ lo)) = Just (hd, BQ tl)
- where
- !hd = (lo .&. 1) /= 0
- !tl = shiftQBR1 bq
-{-# INLINE unconsQ #-}
-
--- | Convert a bit queue to a list of bits by unconsing.
--- This is used to test that the queue functions properly.
-toListQ :: BitQueue -> [Bool]
-toListQ bq = case unconsQ bq of
- Nothing -> []
- Just (hd, tl) -> hd : toListQ tl
=====================================
compiler/GHC/Utils/Containers/Internal/Coercions.hs deleted
=====================================
@@ -1,44 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# OPTIONS_HADDOCK hide #-}
-
-#include "containers.h"
-
-module Utils.Containers.Internal.Coercions where
-
-#ifdef __GLASGOW_HASKELL__
-import Data.Coerce
-#endif
-
-infixl 8 .#
-#ifdef __GLASGOW_HASKELL__
-(.#) :: Coercible b a => (b -> c) -> (a -> b) -> a -> c
-(.#) f _ = coerce f
-#else
-(.#) :: (b -> c) -> (a -> b) -> a -> c
-(.#) = (.)
-#endif
-{-# INLINE (.#) #-}
-
-infix 9 .^#
-
--- | Coerce the second argument of a function. Conceptually,
--- can be thought of as:
---
--- @
--- (f .^# g) x y = f x (g y)
--- @
---
--- However it is most useful when coercing the arguments to
--- 'foldl':
---
--- @
--- foldl f b . fmap g = foldl (f .^# g) b
--- @
-#ifdef __GLASGOW_HASKELL__
-(.^#) :: Coercible c b => (a -> c -> d) -> (b -> c) -> (a -> b -> d)
-(.^#) f _ = coerce f
-#else
-(.^#) :: (a -> c -> d) -> (b -> c) -> (a -> b -> d)
-(f .^# g) x y = f x (g y)
-#endif
-{-# INLINE (.^#) #-}
=====================================
compiler/GHC/Utils/Containers/Internal/PtrEquality.hs deleted
=====================================
@@ -1,42 +0,0 @@
-{-# LANGUAGE CPP #-}
-#ifdef __GLASGOW_HASKELL__
-{-# LANGUAGE MagicHash #-}
-#endif
-
-{-# OPTIONS_HADDOCK hide #-}
-
--- | Really unsafe pointer equality
-module Utils.Containers.Internal.PtrEquality (ptrEq, hetPtrEq) where
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Exts ( reallyUnsafePtrEquality# )
-import Unsafe.Coerce ( unsafeCoerce )
-import GHC.Exts ( Int#, isTrue# )
-#endif
-
--- | Checks if two pointers are equal. Yes means yes;
--- no means maybe. The values should be forced to at least
--- WHNF before comparison to get moderately reliable results.
-ptrEq :: a -> a -> Bool
-
--- | Checks if two pointers are equal, without requiring
--- them to have the same type. The values should be forced
--- to at least WHNF before comparison to get moderately
--- reliable results.
-hetPtrEq :: a -> b -> Bool
-
-#ifdef __GLASGOW_HASKELL__
-ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y)
-hetPtrEq x y = isTrue# (unsafeCoerce (reallyUnsafePtrEquality# :: x -> x -> Int#) x y)
-
-#else
--- Not GHC
-ptrEq _ _ = False
-hetPtrEq _ _ = False
-#endif
-
-{-# INLINE ptrEq #-}
-{-# INLINE hetPtrEq #-}
-
-infix 4 `ptrEq`
-infix 4 `hetPtrEq`
=====================================
compiler/GHC/Utils/Containers/Internal/State.hs deleted
=====================================
@@ -1,36 +0,0 @@
-{-# LANGUAGE CPP #-}
-#include "containers.h"
-{-# OPTIONS_HADDOCK hide #-}
-
--- | A clone of Control.Monad.State.Strict.
-module Utils.Containers.Internal.State where
-
-import Control.Monad (ap, liftM2)
-import Control.Applicative (liftA)
-import Utils.Containers.Internal.Prelude
-import Prelude ()
-
-newtype State s a = State {runState :: s -> (s, a)}
-
-instance Functor (State s) where
- fmap = liftA
-
-instance Monad (State s) where
- {-# INLINE return #-}
- {-# INLINE (>>=) #-}
- return = pure
- m >>= k = State $ \ s -> case runState m s of
- (s', x) -> runState (k x) s'
-
-instance Applicative (State s) where
- {-# INLINE pure #-}
- pure x = State $ \ s -> (s, x)
- (<*>) = ap
- m *> n = State $ \s -> case runState m s of
- (s', _) -> runState n s'
-#if MIN_VERSION_base(4,10,0)
- liftA2 = liftM2
-#endif
-
-execState :: State s a -> s -> a
-execState m x = snd (runState m x)
=====================================
compiler/GHC/Utils/Containers/Internal/StrictMaybe.hs deleted
=====================================
@@ -1,26 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-#include "containers.h"
-
-{-# OPTIONS_HADDOCK hide #-}
--- | Strict 'Maybe'
-
-module Utils.Containers.Internal.StrictMaybe (MaybeS (..), maybeS, toMaybe, toMaybeS) where
-
-data MaybeS a = NothingS | JustS !a
-
-instance Foldable MaybeS where
- foldMap _ NothingS = mempty
- foldMap f (JustS a) = f a
-
-maybeS :: r -> (a -> r) -> MaybeS a -> r
-maybeS n _ NothingS = n
-maybeS _ j (JustS a) = j a
-
-toMaybe :: MaybeS a -> Maybe a
-toMaybe NothingS = Nothing
-toMaybe (JustS a) = Just a
-
-toMaybeS :: Maybe a -> MaybeS a
-toMaybeS Nothing = NothingS
-toMaybeS (Just a) = JustS a
=====================================
compiler/GHC/Utils/Containers/Internal/TypeError.hs deleted
=====================================
@@ -1,44 +0,0 @@
-{-# LANGUAGE DataKinds, FlexibleInstances, FlexibleContexts, UndecidableInstances,
- KindSignatures, TypeFamilies, CPP #-}
-
-#if !defined(TESTING)
-{-# LANGUAGE Safe #-}
-#endif
-
--- | Unsatisfiable constraints for functions being removed.
-
-module Utils.Containers.Internal.TypeError where
-import GHC.TypeLits
-
--- | The constraint @Whoops s@ is unsatisfiable for every 'Symbol' @s at . Trying
--- to use a function with a @Whoops s@ constraint will lead to a pretty type
--- error explaining how to fix the problem.
---
--- ==== Example
---
--- @
--- oldFunction :: Whoops "oldFunction is gone now. Use newFunction."
--- => Int -> IntMap a -> IntMap a
--- @
-class Whoops (a :: Symbol)
-
-instance TypeError ('Text a) => Whoops a
-
--- Why don't we just use
---
--- type Whoops a = TypeError ('Text a) ?
---
--- When GHC sees the type signature of oldFunction, it will see that it
--- has an unsatisfiable constraint and reject it out of hand.
---
--- It seems possible to hack around that with a type family:
---
--- type family Whoops a where
--- Whoops a = TypeError ('Text a)
---
--- but I don't really trust that to work reliably. What we actually
--- do is pretty much guaranteed to work. Despite the fact that there
--- is a totally polymorphic instance in scope, GHC will refrain from
--- reducing the constraint because it knows someone could (theoretically)
--- define an overlapping instance of Whoops. It doesn't commit to
--- the polymorphic one until it has to, at the call site.
=====================================
compiler/ghc.cabal.in
=====================================
@@ -407,6 +407,13 @@ Library
GHC.Data.TrieMap
GHC.Data.Unboxed
GHC.Data.UnionFind
+ GHC.Data.Word64Set
+ GHC.Data.Word64Set.Internal
+ GHC.Data.Word64Map
+ GHC.Data.Word64Map.Internal
+ GHC.Data.Word64Map.Lazy
+ GHC.Data.Word64Map.Strict
+ GHC.Data.Word64Map.Strict.Internal
GHC.Driver.Backend
GHC.Driver.Backend.Internal
GHC.Driver.Backpack
@@ -866,6 +873,9 @@ Library
GHC.Utils.BufHandle
GHC.Utils.CliOption
GHC.Utils.Constants
+ GHC.Utils.Containers.Internal.Prelude
+ GHC.Utils.Containers.Internal.BitUtil
+ GHC.Utils.Containers.Internal.StrictPair
GHC.Utils.Error
GHC.Utils.Exception
GHC.Utils.Fingerprint
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -380,7 +380,7 @@ data EvalStatus_ a b
| EvalBreak Bool
HValueRef{- AP_STACK -}
Int {- break index -}
- Int {- uniq of ModuleName -}
+ Word64 {- uniq of ModuleName -}
(RemoteRef (ResumeContext b))
(RemotePtr CostCentreStack) -- Cost centre stack
deriving (Generic, Show)
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -293,7 +293,7 @@ withBreakAction opts breakMVar statusMVar act
resume_r <- mkRemoteRef resume
apStack_r <- mkRemoteRef apStack
ccs <- toRemotePtr <$> getCCSOf apStack
- putMVar statusMVar $ EvalBreak is_exception apStack_r (I# ix#) (I# uniq#) resume_r ccs
+ putMVar statusMVar $ EvalBreak is_exception apStack_r (I# ix#) (undefined uniq#) resume_r ccs
takeMVar breakMVar
resetBreakAction stablePtr = do
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f83f8b4158ccabd02d4ef16b111c3e2f78738223
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f83f8b4158ccabd02d4ef16b111c3e2f78738223
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230602/74c4b0a5/attachment-0001.html>
More information about the ghc-commits
mailing list