[Git][ghc/ghc][wip/romes/no-this-unit-id-ghc] working this out
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Mon Mar 6 15:03:17 UTC 2023
Rodrigo Mesquita pushed to branch wip/romes/no-this-unit-id-ghc at Glasgow Haskell Compiler / GHC
Commits:
66cc9306 by romes at 2023-03-06T15:02:59+00:00
working this out
- - - - -
11 changed files:
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Builtin/Utils.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Ext/Binary.hs
- compiler/GHC/Iface/Ext/Debug.hs
- compiler/GHC/Iface/Ext/Types.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/Tc/Errors/Hole.hs
- compiler/GHC/Unit/State.hs
- compiler/GHC/Unit/Types.hs
Changes:
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -198,317 +198,319 @@ names with uniques. These ones are the *non* wired-in ones. The
wired in ones are defined in GHC.Builtin.Types etc.
-}
-basicKnownKeyNames :: [Name] -- See Note [Known-key names]
+basicKnownKeyNames :: IO [Name] -- See Note [Known-key names]
basicKnownKeyNames
- = genericTyConNames
- ++ [ -- Classes. *Must* include:
- -- classes that are grabbed by key (e.g., eqClassKey)
- -- classes in "Class.standardClassKeys" (quite a few)
- eqClassName, -- mentioned, derivable
- ordClassName, -- derivable
- boundedClassName, -- derivable
- numClassName, -- mentioned, numeric
- enumClassName, -- derivable
- monadClassName,
- functorClassName,
- realClassName, -- numeric
- integralClassName, -- numeric
- fractionalClassName, -- numeric
- floatingClassName, -- numeric
- realFracClassName, -- numeric
- realFloatClassName, -- numeric
- dataClassName,
- isStringClassName,
- applicativeClassName,
- alternativeClassName,
- foldableClassName,
- traversableClassName,
- semigroupClassName, sappendName,
- monoidClassName, memptyName, mappendName, mconcatName,
-
- -- The IO type
- ioTyConName, ioDataConName,
- runMainIOName,
- runRWName,
-
- -- Type representation types
- trModuleTyConName, trModuleDataConName,
- trNameTyConName, trNameSDataConName, trNameDDataConName,
- trTyConTyConName, trTyConDataConName,
-
- -- Typeable
- typeableClassName,
- typeRepTyConName,
- someTypeRepTyConName,
- someTypeRepDataConName,
- kindRepTyConName,
- kindRepTyConAppDataConName,
- kindRepVarDataConName,
- kindRepAppDataConName,
- kindRepFunDataConName,
- kindRepTYPEDataConName,
- kindRepTypeLitSDataConName,
- kindRepTypeLitDDataConName,
- typeLitSortTyConName,
- typeLitSymbolDataConName,
- typeLitNatDataConName,
- typeLitCharDataConName,
- typeRepIdName,
- mkTrTypeName,
- mkTrConName,
- mkTrAppName,
- mkTrFunName,
- typeSymbolTypeRepName, typeNatTypeRepName, typeCharTypeRepName,
- trGhcPrimModuleName,
-
- -- KindReps for common cases
- starKindRepName,
- starArrStarKindRepName,
- starArrStarArrStarKindRepName,
- constraintKindRepName,
-
- -- WithDict
- withDictClassName,
-
- -- Dynamic
- toDynName,
-
- -- Numeric stuff
- negateName, minusName, geName, eqName,
- mkRationalBase2Name, mkRationalBase10Name,
-
- -- Conversion functions
- rationalTyConName,
- ratioTyConName, ratioDataConName,
- fromRationalName, fromIntegerName,
- toIntegerName, toRationalName,
- fromIntegralName, realToFracName,
-
- -- Int# stuff
- divIntName, modIntName,
-
- -- String stuff
- fromStringName,
-
- -- Enum stuff
- enumFromName, enumFromThenName,
- enumFromThenToName, enumFromToName,
-
- -- Applicative stuff
- pureAName, apAName, thenAName,
-
- -- Functor stuff
- fmapName,
-
- -- Monad stuff
- thenIOName, bindIOName, returnIOName, failIOName, bindMName, thenMName,
- returnMName, joinMName,
-
- -- MonadFail
- monadFailClassName, failMName,
-
- -- MonadFix
- monadFixClassName, mfixName,
-
- -- Arrow stuff
- arrAName, composeAName, firstAName,
- appAName, choiceAName, loopAName,
-
- -- Ix stuff
- ixClassName,
-
- -- Show stuff
- showClassName,
-
- -- Read stuff
- readClassName,
-
- -- Stable pointers
- newStablePtrName,
-
- -- GHC Extensions
- considerAccessibleName,
-
- -- Strings and lists
- unpackCStringName, unpackCStringUtf8Name,
- unpackCStringAppendName, unpackCStringAppendUtf8Name,
- unpackCStringFoldrName, unpackCStringFoldrUtf8Name,
- cstringLengthName,
-
- -- Overloaded lists
- isListClassName,
- fromListName,
- fromListNName,
- toListName,
-
- -- Non-empty lists
- nonEmptyTyConName,
-
- -- Overloaded record dot, record update
- getFieldName, setFieldName,
-
- -- List operations
- concatName, filterName, mapName,
- zipName, foldrName, buildName, augmentName, appendName,
-
- -- FFI primitive types that are not wired-in.
- stablePtrTyConName, ptrTyConName, funPtrTyConName, constPtrConName,
- int8TyConName, int16TyConName, int32TyConName, int64TyConName,
- word8TyConName, word16TyConName, word32TyConName, word64TyConName,
-
- -- Others
- otherwiseIdName, inlineIdName,
- eqStringName, assertName,
- assertErrorName, traceName,
- printName,
- dollarName,
-
- -- ghc-bignum
- integerFromNaturalName,
- integerToNaturalClampName,
- integerToNaturalThrowName,
- integerToNaturalName,
- integerToWordName,
- integerToIntName,
- integerToWord64Name,
- integerToInt64Name,
- integerFromWordName,
- integerFromWord64Name,
- integerFromInt64Name,
- integerAddName,
- integerMulName,
- integerSubName,
- integerNegateName,
- integerAbsName,
- integerPopCountName,
- integerQuotName,
- integerRemName,
- integerDivName,
- integerModName,
- integerDivModName,
- integerQuotRemName,
- integerEncodeFloatName,
- integerEncodeDoubleName,
- integerGcdName,
- integerLcmName,
- integerAndName,
- integerOrName,
- integerXorName,
- integerComplementName,
- integerBitName,
- integerTestBitName,
- integerShiftLName,
- integerShiftRName,
-
- naturalToWordName,
- naturalPopCountName,
- naturalShiftRName,
- naturalShiftLName,
- naturalAddName,
- naturalSubName,
- naturalSubThrowName,
- naturalSubUnsafeName,
- naturalMulName,
- naturalQuotRemName,
- naturalQuotName,
- naturalRemName,
- naturalAndName,
- naturalAndNotName,
- naturalOrName,
- naturalXorName,
- naturalTestBitName,
- naturalBitName,
- naturalGcdName,
- naturalLcmName,
- naturalLog2Name,
- naturalLogBaseWordName,
- naturalLogBaseName,
- naturalPowModName,
- naturalSizeInBaseName,
-
- bignatFromWordListName,
- bignatEqName,
-
- -- Float/Double
- integerToFloatName,
- integerToDoubleName,
- naturalToFloatName,
- naturalToDoubleName,
- rationalToFloatName,
- rationalToDoubleName,
-
- -- Other classes
- monadPlusClassName,
-
- -- Type-level naturals
- knownNatClassName, knownSymbolClassName, knownCharClassName,
-
- -- Overloaded labels
- fromLabelClassOpName,
-
- -- Implicit Parameters
- ipClassName,
-
- -- Overloaded record fields
- hasFieldClassName,
-
- -- Call Stacks
- callStackTyConName,
- emptyCallStackName, pushCallStackName,
-
- -- Source Locations
- srcLocDataConName,
-
- -- Annotation type checking
- toAnnotationWrapperName
-
- -- The SPEC type for SpecConstr
- , specTyConName
-
- -- The Either type
- , eitherTyConName, leftDataConName, rightDataConName
-
- -- The Void type
- , voidTyConName
-
+ = sequence [
-- Plugins
- , pluginTyConName
+ pluginTyConName
, frontendPluginTyConName
-
- -- Generics
- , genClassName, gen1ClassName
- , datatypeClassName, constructorClassName, selectorClassName
-
- -- Monad comprehensions
- , guardMName
- , liftMName
- , mzipName
-
- -- GHCi Sandbox
- , ghciIoClassName, ghciStepIoMName
-
- -- StaticPtr
- , makeStaticName
- , staticPtrTyConName
- , staticPtrDataConName, staticPtrInfoDataConName
- , fromStaticPtrName
-
- -- Fingerprint
- , fingerprintDataConName
-
- -- Custom type errors
- , errorMessageTypeErrorFamName
- , typeErrorTextDataConName
- , typeErrorAppendDataConName
- , typeErrorVAppendDataConName
- , typeErrorShowTypeDataConName
-
- -- Unsafe coercion proofs
- , unsafeEqualityProofName
- , unsafeEqualityTyConName
- , unsafeReflDataConName
- , unsafeCoercePrimName
- ]
+ ] >>= \ioknownnames ->
+ pure (ioknownnames ++
+ genericTyConNames
+ ++ [ -- Classes. *Must* include:
+ -- classes that are grabbed by key (e.g., eqClassKey)
+ -- classes in "Class.standardClassKeys" (quite a few)
+ eqClassName, -- mentioned, derivable
+ ordClassName, -- derivable
+ boundedClassName, -- derivable
+ numClassName, -- mentioned, numeric
+ enumClassName, -- derivable
+ monadClassName,
+ functorClassName,
+ realClassName, -- numeric
+ integralClassName, -- numeric
+ fractionalClassName, -- numeric
+ floatingClassName, -- numeric
+ realFracClassName, -- numeric
+ realFloatClassName, -- numeric
+ dataClassName,
+ isStringClassName,
+ applicativeClassName,
+ alternativeClassName,
+ foldableClassName,
+ traversableClassName,
+ semigroupClassName, sappendName,
+ monoidClassName, memptyName, mappendName, mconcatName,
+
+ -- The IO type
+ ioTyConName, ioDataConName,
+ runMainIOName,
+ runRWName,
+
+ -- Type representation types
+ trModuleTyConName, trModuleDataConName,
+ trNameTyConName, trNameSDataConName, trNameDDataConName,
+ trTyConTyConName, trTyConDataConName,
+
+ -- Typeable
+ typeableClassName,
+ typeRepTyConName,
+ someTypeRepTyConName,
+ someTypeRepDataConName,
+ kindRepTyConName,
+ kindRepTyConAppDataConName,
+ kindRepVarDataConName,
+ kindRepAppDataConName,
+ kindRepFunDataConName,
+ kindRepTYPEDataConName,
+ kindRepTypeLitSDataConName,
+ kindRepTypeLitDDataConName,
+ typeLitSortTyConName,
+ typeLitSymbolDataConName,
+ typeLitNatDataConName,
+ typeLitCharDataConName,
+ typeRepIdName,
+ mkTrTypeName,
+ mkTrConName,
+ mkTrAppName,
+ mkTrFunName,
+ typeSymbolTypeRepName, typeNatTypeRepName, typeCharTypeRepName,
+ trGhcPrimModuleName,
+
+ -- KindReps for common cases
+ starKindRepName,
+ starArrStarKindRepName,
+ starArrStarArrStarKindRepName,
+ constraintKindRepName,
+
+ -- WithDict
+ withDictClassName,
+
+ -- Dynamic
+ toDynName,
+
+ -- Numeric stuff
+ negateName, minusName, geName, eqName,
+ mkRationalBase2Name, mkRationalBase10Name,
+
+ -- Conversion functions
+ rationalTyConName,
+ ratioTyConName, ratioDataConName,
+ fromRationalName, fromIntegerName,
+ toIntegerName, toRationalName,
+ fromIntegralName, realToFracName,
+
+ -- Int# stuff
+ divIntName, modIntName,
+
+ -- String stuff
+ fromStringName,
+
+ -- Enum stuff
+ enumFromName, enumFromThenName,
+ enumFromThenToName, enumFromToName,
+
+ -- Applicative stuff
+ pureAName, apAName, thenAName,
+
+ -- Functor stuff
+ fmapName,
+
+ -- Monad stuff
+ thenIOName, bindIOName, returnIOName, failIOName, bindMName, thenMName,
+ returnMName, joinMName,
+
+ -- MonadFail
+ monadFailClassName, failMName,
+
+ -- MonadFix
+ monadFixClassName, mfixName,
+
+ -- Arrow stuff
+ arrAName, composeAName, firstAName,
+ appAName, choiceAName, loopAName,
+
+ -- Ix stuff
+ ixClassName,
+
+ -- Show stuff
+ showClassName,
+
+ -- Read stuff
+ readClassName,
+
+ -- Stable pointers
+ newStablePtrName,
+
+ -- GHC Extensions
+ considerAccessibleName,
+
+ -- Strings and lists
+ unpackCStringName, unpackCStringUtf8Name,
+ unpackCStringAppendName, unpackCStringAppendUtf8Name,
+ unpackCStringFoldrName, unpackCStringFoldrUtf8Name,
+ cstringLengthName,
+
+ -- Overloaded lists
+ isListClassName,
+ fromListName,
+ fromListNName,
+ toListName,
+
+ -- Non-empty lists
+ nonEmptyTyConName,
+
+ -- Overloaded record dot, record update
+ getFieldName, setFieldName,
+
+ -- List operations
+ concatName, filterName, mapName,
+ zipName, foldrName, buildName, augmentName, appendName,
+
+ -- FFI primitive types that are not wired-in.
+ stablePtrTyConName, ptrTyConName, funPtrTyConName, constPtrConName,
+ int8TyConName, int16TyConName, int32TyConName, int64TyConName,
+ word8TyConName, word16TyConName, word32TyConName, word64TyConName,
+
+ -- Others
+ otherwiseIdName, inlineIdName,
+ eqStringName, assertName,
+ assertErrorName, traceName,
+ printName,
+ dollarName,
+
+ -- ghc-bignum
+ integerFromNaturalName,
+ integerToNaturalClampName,
+ integerToNaturalThrowName,
+ integerToNaturalName,
+ integerToWordName,
+ integerToIntName,
+ integerToWord64Name,
+ integerToInt64Name,
+ integerFromWordName,
+ integerFromWord64Name,
+ integerFromInt64Name,
+ integerAddName,
+ integerMulName,
+ integerSubName,
+ integerNegateName,
+ integerAbsName,
+ integerPopCountName,
+ integerQuotName,
+ integerRemName,
+ integerDivName,
+ integerModName,
+ integerDivModName,
+ integerQuotRemName,
+ integerEncodeFloatName,
+ integerEncodeDoubleName,
+ integerGcdName,
+ integerLcmName,
+ integerAndName,
+ integerOrName,
+ integerXorName,
+ integerComplementName,
+ integerBitName,
+ integerTestBitName,
+ integerShiftLName,
+ integerShiftRName,
+
+ naturalToWordName,
+ naturalPopCountName,
+ naturalShiftRName,
+ naturalShiftLName,
+ naturalAddName,
+ naturalSubName,
+ naturalSubThrowName,
+ naturalSubUnsafeName,
+ naturalMulName,
+ naturalQuotRemName,
+ naturalQuotName,
+ naturalRemName,
+ naturalAndName,
+ naturalAndNotName,
+ naturalOrName,
+ naturalXorName,
+ naturalTestBitName,
+ naturalBitName,
+ naturalGcdName,
+ naturalLcmName,
+ naturalLog2Name,
+ naturalLogBaseWordName,
+ naturalLogBaseName,
+ naturalPowModName,
+ naturalSizeInBaseName,
+
+ bignatFromWordListName,
+ bignatEqName,
+
+ -- Float/Double
+ integerToFloatName,
+ integerToDoubleName,
+ naturalToFloatName,
+ naturalToDoubleName,
+ rationalToFloatName,
+ rationalToDoubleName,
+
+ -- Other classes
+ monadPlusClassName,
+
+ -- Type-level naturals
+ knownNatClassName, knownSymbolClassName, knownCharClassName,
+
+ -- Overloaded labels
+ fromLabelClassOpName,
+
+ -- Implicit Parameters
+ ipClassName,
+
+ -- Overloaded record fields
+ hasFieldClassName,
+
+ -- Call Stacks
+ callStackTyConName,
+ emptyCallStackName, pushCallStackName,
+
+ -- Source Locations
+ srcLocDataConName,
+
+ -- Annotation type checking
+ toAnnotationWrapperName
+
+ -- The SPEC type for SpecConstr
+ , specTyConName
+
+ -- The Either type
+ , eitherTyConName, leftDataConName, rightDataConName
+
+ -- The Void type
+ , voidTyConName
+
+ -- Generics
+ , genClassName, gen1ClassName
+ , datatypeClassName, constructorClassName, selectorClassName
+
+ -- Monad comprehensions
+ , guardMName
+ , liftMName
+ , mzipName
+
+ -- GHCi Sandbox
+ , ghciIoClassName, ghciStepIoMName
+
+ -- StaticPtr
+ , makeStaticName
+ , staticPtrTyConName
+ , staticPtrDataConName, staticPtrInfoDataConName
+ , fromStaticPtrName
+
+ -- Fingerprint
+ , fingerprintDataConName
+
+ -- Custom type errors
+ , errorMessageTypeErrorFamName
+ , typeErrorTextDataConName
+ , typeErrorAppendDataConName
+ , typeErrorVAppendDataConName
+ , typeErrorShowTypeDataConName
+
+ -- Unsafe coercion proofs
+ , unsafeEqualityProofName
+ , unsafeEqualityTyConName
+ , unsafeReflDataConName
+ , unsafeCoercePrimName
+ ])
genericTyConNames :: [Name]
genericTyConNames = [
@@ -1631,12 +1633,12 @@ srcLocDataConName
= dcQual gHC_STACK_TYPES (fsLit "SrcLoc") srcLocDataConKey
-- plugins
-pLUGINS :: Module
-pLUGINS = mkThisGhcModule (fsLit "GHC.Driver.Plugins")
-pluginTyConName :: Name
-pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey
-frontendPluginTyConName :: Name
-frontendPluginTyConName = tcQual pLUGINS (fsLit "FrontendPlugin") frontendPluginTyConKey
+pLUGINS :: IO Module
+pLUGINS = pure $ mkThisGhcModule (fsLit "GHC.Driver.Plugins")
+pluginTyConName :: IO Name
+pluginTyConName = pLUGINS >>= \plugin_mod -> pure (tcQual plugin_mod (fsLit "Plugin") pluginTyConKey)
+frontendPluginTyConName :: IO Name
+frontendPluginTyConName = pLUGINS >>= \plugin_mod -> pure (tcQual plugin_mod (fsLit "FrontendPlugin") frontendPluginTyConKey)
-- Static pointers
makeStaticName :: Name
=====================================
compiler/GHC/Builtin/Utils.hs
=====================================
@@ -113,7 +113,7 @@ Note [About wired-in things]
-- | This list is used to ensure that when you say "Prelude.map" in your source
-- code, or in an interface file, you get a Name with the correct known key (See
-- Note [Known-key names] in "GHC.Builtin.Names")
-knownKeyNames :: [Name]
+knownKeyNames :: IO [Name]
knownKeyNames
| debugIsOn
, Just badNamesStr <- knownKeyNamesOkay all_names
@@ -123,7 +123,7 @@ knownKeyNames
-- "<<details unavailable>>" error. (This seems to happen only in the
-- stage 2 compiler, for reasons I [Richard] have no clue of.)
| otherwise
- = all_names
+ = (++) all_names <$> basicKnownKeyNames
where
all_names =
concat [ concatMap wired_tycon_kk_names primTyCons
@@ -132,7 +132,6 @@ knownKeyNames
, map idName wiredInIds
, map idName allThePrimOpIds
, map (idName . primOpWrapperId) allThePrimOps
- , basicKnownKeyNames
, templateHaskellNames
]
-- All of the names associated with a wired-in TyCon.
@@ -189,22 +188,22 @@ knownKeyNamesOkay all_names
-- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a
-- known-key thing.
-lookupKnownKeyName :: Unique -> Maybe Name
+lookupKnownKeyName :: Unique -> IO (Maybe Name)
lookupKnownKeyName u =
- knownUniqueName u <|> lookupUFM_Directly knownKeysMap u
+ (knownUniqueName u <|>) . flip lookupUFM_Directly u <$> knownKeysMap
-- | Is a 'Name' known-key?
-isKnownKeyName :: Name -> Bool
+isKnownKeyName :: Name -> IO Bool
isKnownKeyName n =
- isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap
+ (isJust (knownUniqueName $ nameUnique n) ||) . elemUFM n <$> knownKeysMap
-- | Maps 'Unique's to known-key names.
--
-- The type is @UniqFM Name Name@ to denote that the 'Unique's used
-- in the domain are 'Unique's associated with 'Name's (as opposed
-- to some other namespace of 'Unique's).
-knownKeysMap :: UniqFM Name Name
-knownKeysMap = listToIdentityUFM knownKeyNames
+knownKeysMap :: IO (UniqFM Name Name)
+knownKeysMap = listToIdentityUFM <$> knownKeyNames
-- | Given a 'Unique' lookup any associated arbitrary SDoc's to be displayed by
-- GHCi's ':info' command.
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -305,7 +305,8 @@ newHscEnv top_dir dflags = newHscEnvWithHUG top_dir dflags (homeUnitId_ dflags)
newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv
newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do
- nc_var <- initNameCache 'r' knownKeyNames
+ knownKeyNames' <- knownKeyNames
+ nc_var <- initNameCache 'r' knownKeyNames'
fc_var <- initFinderCache
logger <- initLogger
tmpfs <- initTmpFs
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE BinaryLiterals, ScopedTypeVariables #-}
+{-# LANGUAGE BinaryLiterals, ScopedTypeVariables, LambdaCase #-}
--
-- (c) The University of Glasgow 2002-2006
@@ -336,18 +336,17 @@ putName _dict BinSymbolTable{
bin_symtab_map = symtab_map_ref,
bin_symtab_next = symtab_next }
bh name
- | isKnownKeyName name
- , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
= -- assert (u < 2^(22 :: Int))
- put_ bh (0x80000000
- .|. (fromIntegral (ord c) `shiftL` 22)
- .|. (fromIntegral u :: Word32))
-
- | otherwise
- = do symtab_map <- readIORef symtab_map_ref
- case lookupUFM symtab_map name of
- Just (off,_) -> put_ bh (fromIntegral off :: Word32)
- Nothing -> do
+ isKnownKeyName name >>= \case
+ True -> let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
+ in put_ bh (0x80000000
+ .|. (fromIntegral (ord c) `shiftL` 22)
+ .|. (fromIntegral u :: Word32))
+ False -> do
+ symtab_map <- readIORef symtab_map_ref
+ case lookupUFM symtab_map name of
+ Just (off,_) -> put_ bh (fromIntegral off :: Word32)
+ Nothing -> do
off <- readFastMutInt symtab_next
-- massert (off < 2^(30 :: Int))
writeFastMutInt symtab_next (off+1)
@@ -370,10 +369,10 @@ getSymtabName _name_cache _dict symtab bh = do
ix = fromIntegral i .&. 0x003FFFFF
u = mkUnique tag ix
in
- return $! case lookupKnownKeyName u of
- Nothing -> pprPanic "getSymtabName:unknown known-key unique"
- (ppr i $$ ppr u $$ char tag $$ ppr ix)
- Just n -> n
+ lookupKnownKeyName u >>= \case
+ Nothing -> pprPanic "getSymtabName:unknown known-key unique"
+ (ppr i $$ ppr u $$ char tag $$ ppr ix)
+ Just n -> return $! n
_ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
=====================================
compiler/GHC/Iface/Ext/Binary.hs
=====================================
@@ -3,6 +3,7 @@ Binary serialization for .hie files.
-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
module GHC.Iface.Ext.Binary
( readHieFile
@@ -291,15 +292,18 @@ putName (HieSymbolTable next ref) bh name = do
let hieName = ExternalName mod occ (nameSrcSpan name)
writeIORef ref $! addToUFM symmap name (off, hieName)
put_ bh (fromIntegral off :: Word32)
- Just (off, LocalName _occ span)
- | notLocal (toHieName name) || nameSrcSpan name /= span -> do
- writeIORef ref $! addToUFM symmap name (off, toHieName name)
- put_ bh (fromIntegral off :: Word32)
+ Just (off, LocalName _occ span) -> do
+ hieName <- toHieName name
+ if notLocal (hieName) || nameSrcSpan name /= span then do
+ writeIORef ref $! addToUFM symmap name (off, hieName)
+ put_ bh (fromIntegral off :: Word32)
+ else put_ bh (fromIntegral off :: Word32) -- ROMES:TODO can we not duplicate this here as below?
Just (off, _) -> put_ bh (fromIntegral off :: Word32)
Nothing -> do
+ hieName <- toHieName name
off <- readFastMutInt next
writeFastMutInt next (off+1)
- writeIORef ref $! addToUFM symmap name (off, toHieName name)
+ writeIORef ref $! addToUFM symmap name (off, hieName)
put_ bh (fromIntegral off :: Word32)
where
@@ -328,7 +332,7 @@ fromHieName nc hie_name = do
-- don't update the NameCache for local names
pure $ mkInternalName uniq occ span
- KnownKeyName u -> case lookupKnownKeyName u of
+ KnownKeyName u -> lookupKnownKeyName u >>= \case
Nothing -> pprPanic "fromHieName:unknown known-key unique"
(ppr u)
Just n -> pure n
=====================================
compiler/GHC/Iface/Ext/Debug.hs
=====================================
@@ -22,6 +22,8 @@ import qualified Data.Set as S
import Data.Function ( on )
import Data.List ( sortOn )
+import System.IO.Unsafe ( unsafePerformIO )
+
type Diff a = a -> a -> [SDoc]
diffFile :: Diff HieFile
@@ -64,10 +66,10 @@ diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) =
type DiffIdent = Either ModuleName HieName
normalizeIdents :: Ord a => NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)]
-normalizeIdents = sortOn go . map (first toHieName) . M.toList
+normalizeIdents = sortOn go . map (first (unsafePerformIO . toHieName)) . M.toList
where
first f (a,b) = (fmap f a, b)
- go (a,b) = (hieNameOcc <$> a,identInfo b,identType b)
+ go (a,b) = (unsafePerformIO . hieNameOcc <$> a,identInfo b,identType b)
diffList :: Diff a -> Diff [a]
diffList f xs ys
=====================================
compiler/GHC/Iface/Ext/Types.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -42,6 +43,8 @@ import Data.Coerce ( coerce )
import Data.Function ( on )
import qualified Data.Semigroup as S
+import System.IO.Unsafe ( unsafePerformIO )
+
type Span = RealSrcSpan
-- | Current version of @.hie@ files
@@ -581,10 +584,10 @@ newtype EvBindDeps = EvBindDeps { getEvBindDeps :: [Name] }
deriving Outputable
instance Eq EvBindDeps where
- (==) = coerce ((==) `on` map toHieName)
+ (==) = coerce ((==) `on` map (unsafePerformIO . toHieName))
instance Ord EvBindDeps where
- compare = coerce (compare `on` map toHieName)
+ compare = coerce (compare `on` map (unsafePerformIO . toHieName))
instance Binary EvBindDeps where
put_ bh (EvBindDeps xs) = put_ bh xs
@@ -767,19 +770,25 @@ instance Outputable HieName where
ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp
ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u
-hieNameOcc :: HieName -> OccName
-hieNameOcc (ExternalName _ occ _) = occ
-hieNameOcc (LocalName occ _) = occ
+-- Why do we need IO? See Note [Looking up known key names]
+hieNameOcc :: HieName -> IO OccName
+hieNameOcc (ExternalName _ occ _) = pure occ
+hieNameOcc (LocalName occ _) = pure occ
hieNameOcc (KnownKeyName u) =
- case lookupKnownKeyName u of
- Just n -> nameOccName n
+ lookupKnownKeyName u >>= \case
+ Just n -> pure (nameOccName n)
Nothing -> pprPanic "hieNameOcc:unknown known-key unique"
(ppr u)
-toHieName :: Name -> HieName
-toHieName name
- | isKnownKeyName name = KnownKeyName (nameUnique name)
- | isExternalName name = ExternalName (nameModule name)
- (nameOccName name)
- (removeBufSpan $ nameSrcSpan name)
- | otherwise = LocalName (nameOccName name) (removeBufSpan $ nameSrcSpan name)
+-- Why do we need IO? See Note [Looking up known key names]
+toHieName :: Name -> IO HieName
+toHieName name =
+ isKnownKeyName name >>= \case
+ True -> pure (KnownKeyName (nameUnique name))
+ False
+ | isExternalName name ->
+ pure $ ExternalName (nameModule name)
+ (nameOccName name)
+ (removeBufSpan $ nameSrcSpan name)
+ | otherwise ->
+ pure $ LocalName (nameOccName name) (removeBufSpan $ nameSrcSpan name)
=====================================
compiler/GHC/Runtime/Loader.hs
=====================================
@@ -138,15 +138,17 @@ loadPlugins hsc_env
where
options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags
, opt_mod_nm == mod_nm ]
- loadPlugin = loadPlugin' (mkVarOccFS (fsLit "plugin")) pluginTyConName hsc_env
+ loadPlugin p = pluginTyConName >>= \pluginTyConName' -> loadPlugin' (mkVarOccFS (fsLit "plugin")) pluginTyConName' hsc_env p
loadFrontendPlugin :: HscEnv -> ModuleName -> IO (FrontendPlugin, [Linkable], PkgsLoaded)
loadFrontendPlugin hsc_env mod_name = do
checkExternalInterpreter hsc_env
(plugin, _iface, links, pkgs)
- <- loadPlugin' (mkVarOccFS (fsLit "frontendPlugin")) frontendPluginTyConName
- hsc_env mod_name
+ <- frontendPluginTyConName >>=
+ \frontendPluginTCN ->
+ loadPlugin' (mkVarOccFS (fsLit "frontendPlugin")) frontendPluginTCN
+ hsc_env mod_name
return (plugin, links, pkgs)
-- #14335
@@ -168,7 +170,7 @@ loadPlugin' occ_name plugin_name hsc_env mod_name
[ text "The module", ppr mod_name
, text "did not export the plugin name"
, ppr plugin_rdr_name ]) ;
- Just (name, mod_iface) ->
+ Just (name, mod_iface) -> pprTrace "ROMES: Current unit" (ppr . ue_current_unit . hsc_unit_env $ hsc_env) $
do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name
; eith_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)
=====================================
compiler/GHC/Tc/Errors/Hole.hs
=====================================
@@ -597,6 +597,7 @@ findValidHoleFits tidy_env implics simples h@(Hole { hole_sort = ExprHole _
; traceTc "hole_lvl is:" $ ppr hole_lvl
; traceTc "simples are: " $ ppr simples
; traceTc "locals are: " $ ppr lclBinds
+ ; builtIns' <- liftIO builtIns
; let (lcl, gbl) = partition gre_lcl (globalRdrEnvElts rdr_env)
-- We remove binding shadowings here, but only for the local level.
-- this is so we e.g. suggest the global fmap from the Functor class
@@ -605,7 +606,7 @@ findValidHoleFits tidy_env implics simples h@(Hole { hole_sort = ExprHole _
locals = removeBindingShadowing $
map IdHFCand lclBinds ++ map GreHFCand lcl
globals = map GreHFCand gbl
- syntax = map NameHFCand builtIns
+ syntax = map NameHFCand builtIns'
-- If the hole is a rigid type-variable, then we only check the
-- locals, since only they can match the type (in a meaningful way).
only_locals = any isImmutableTyVar $ getTyVar_maybe hole_ty
@@ -663,8 +664,8 @@ findValidHoleFits tidy_env implics simples h@(Hole { hole_sort = ExprHole _
hole_lvl = ctLocLevel ct_loc
-- BuiltInSyntax names like (:) and []
- builtIns :: [Name]
- builtIns = filter isBuiltInSyntax knownKeyNames
+ builtIns :: IO [Name]
+ builtIns = filter isBuiltInSyntax <$> knownKeyNames
-- We make a refinement type by adding a new type variable in front
-- of the type of t h hole, going from e.g. [Integer] -> Integer
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -108,6 +108,7 @@ import GHC.Utils.Exception
import System.Directory
import System.FilePath as FilePath
import Control.Monad
+import Data.IORef
import Data.Graph (stronglyConnComp, SCC(..))
import Data.Char ( toUpper )
import Data.List ( intersperse, partition, sortBy, isSuffixOf )
@@ -410,7 +411,7 @@ type ModuleNameProvidersMap =
Map ModuleName (Map Module ModuleOrigin)
data UnitState = UnitState {
- -- | A mapping of 'Unit' to 'UnitInfo'. This list is adjusted
+ -- | A mapping of 'UnitId' to 'UnitInfo'. This list is adjusted
-- so that only valid units are here. 'UnitInfo' reflects
-- what was stored *on disk*, except for the 'trusted' flag, which
-- is adjusted at runtime. (In particular, some units in this map
@@ -430,6 +431,7 @@ data UnitState = UnitState {
-- And also to resolve package qualifiers with the PackageImports extension.
packageNameMap :: UniqFM PackageName UnitId,
+ -- TODO: Remove these two completely?
-- | A mapping from database unit keys to wired in unit ids.
wireMap :: Map UnitId UnitId,
@@ -1096,8 +1098,9 @@ findWiredInUnits logger prec_map pkgs vis_map = do
-- their canonical names (eg. base-1.0 ==> base), as described
-- in Note [Wired-in units] in GHC.Unit.Types
let
- matches :: UnitInfo -> UnitId -> Bool
- pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid)
+ -- Match a package name against a UnitInfo
+ matches :: UnitInfo -> FastString -> Bool
+ pc `matches` pname = unitPackageName pc == PackageName pname
-- find which package corresponds to each wired-in package
-- delete any other packages with the same name
@@ -1116,10 +1119,10 @@ findWiredInUnits logger prec_map pkgs vis_map = do
-- this works even when there is no exposed wired in package
-- available.
--
- findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo))
- findWiredInUnit pkgs wired_pkg = firstJustsM [try all_exposed_ps, try all_ps, notfound]
+ findWiredInUnitByName :: [UnitInfo] -> FastString -> IO (Maybe (FastString, UnitInfo))
+ findWiredInUnitByName pkgs wired_pkg_name = firstJustsM [try all_exposed_ps, try all_ps, notfound] -- ROMES:TODO: In fact, here we ?
where
- all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]
+ all_ps = [ p | p <- pkgs, p `matches` wired_pkg_name ]
all_exposed_ps = [ p | p <- all_ps, Map.member (mkUnit p) vis_map ]
try ps = case sortByPreference prec_map ps of
@@ -1129,26 +1132,27 @@ findWiredInUnits logger prec_map pkgs vis_map = do
notfound = do
debugTraceMsg logger 2 $
text "wired-in package "
- <> ftext (unitIdFS wired_pkg)
+ <> ftext wired_pkg_name
<> text " not found."
return Nothing
- pick :: UnitInfo -> IO (UnitId, UnitInfo)
+
+ pick :: UnitInfo -> IO (FastString, UnitInfo)
pick pkg = do
debugTraceMsg logger 2 $
text "wired-in package "
- <> ftext (unitIdFS wired_pkg)
+ <> ftext wired_pkg_name
<> text " mapped to "
<> ppr (unitId pkg)
- return (wired_pkg, pkg)
+ return (wired_pkg_name, pkg)
- mb_wired_in_pkgs <- mapM (findWiredInUnit pkgs) wiredInUnitIds
+ mb_wired_in_pkgs <- mapM (findWiredInUnitByName pkgs) wiredInUnitNames
let
wired_in_pkgs = catMaybes mb_wired_in_pkgs
wiredInMap :: Map UnitId UnitId
wiredInMap = Map.fromList
- [ (unitId realUnitInfo, wiredInUnitId)
+ [ (unitId realUnitInfo, UnitId wiredInUnitId)
| (wiredInUnitId, realUnitInfo) <- wired_in_pkgs
, not (unitIsIndefinite realUnitInfo)
]
@@ -1608,6 +1612,7 @@ mkUnitState logger cfg = do
-- package arguments we need to key against the old versions.
--
(pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
+
let pkg_db = mkUnitInfoMap pkgs2
-- Update the visibility map, so we treat wired packages as visible.
@@ -1696,6 +1701,8 @@ mkUnitState logger cfg = do
, requirementContext = req_ctx
, allowVirtualUnits = unitConfigAllowVirtual cfg
}
+
+ writeIORef workingThisOut (unwireMap state)
return (state, raw_dbs)
selectHptFlag :: Set.Set UnitId -> PackageFlag -> Bool
=====================================
compiler/GHC/Unit/Types.hs
=====================================
@@ -24,6 +24,8 @@ module GHC.Unit.Types
, pprInstantiatedModule
, moduleFreeHoles
+ , workingThisOut
+
-- * Units
, IsUnitId
, GenUnit (..)
@@ -79,7 +81,7 @@ module GHC.Unit.Types
, interactiveUnit
, isInteractiveModule
- , wiredInUnitIds
+ , wiredInUnitNames
-- * Boot modules
, IsBootInterface (..)
@@ -105,12 +107,23 @@ import Data.Data
import Data.List (sortBy )
import Data.Function
import Data.Bifunctor
+import Data.IORef
+import Data.Map (Map)
+import qualified Data.Map as Map
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS.Char8
+import System.IO.Unsafe
+
import Language.Haskell.Syntax.Module.Name
import {-# SOURCE #-} Language.Haskell.Syntax.ImpExp (IsBootInterface(..))
+-- Ref for an "unwireMap" which maps wired-in ids to actual units, created by
+-- identifying wired-in packages in the list of package-id flags
+workingThisOut :: IORef (Map UnitId UnitId)
+workingThisOut = unsafePerformIO (newIORef (Map.singleton (UnitId $ fsLit "ouch-version") (UnitId $ fsLit "ouch")))
+{-# NOINLINE workingThisOut #-}
+
---------------------------------------------------------------------
-- MODULES
---------------------------------------------------------------------
@@ -587,19 +600,35 @@ Make sure you change 'GHC.Unit.State.findWiredInUnits' if you add an entry here.
-}
+bignumUnitName, primUnitName, baseUnitName, rtsUnitName,
+ thUnitName, mainUnitName, thisGhcUnitName, interactiveUnitName :: FastString
+
bignumUnitId, primUnitId, baseUnitId, rtsUnitId,
thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId
bignumUnit, primUnit, baseUnit, rtsUnit,
thUnit, mainUnit, thisGhcUnit, interactiveUnit :: Unit
-primUnitId = UnitId (fsLit "ghc-prim")
-bignumUnitId = UnitId (fsLit "ghc-bignum")
-baseUnitId = UnitId (fsLit "base")
-rtsUnitId = UnitId (fsLit "rts")
-thisGhcUnitId = UnitId (fsLit "ghc")
-interactiveUnitId = UnitId (fsLit "interactive")
-thUnitId = UnitId (fsLit "template-haskell")
+primUnitName = fsLit "ghc-prim"
+bignumUnitName = fsLit "ghc-bignum"
+baseUnitName = fsLit "base"
+rtsUnitName = fsLit "rts"
+thisGhcUnitName = fsLit "ghc"
+interactiveUnitName = fsLit "interactive"
+thUnitName = fsLit "template-haskell"
+
+primUnitId = UnitId primUnitName
+bignumUnitId = UnitId bignumUnitName
+baseUnitId = UnitId baseUnitName
+rtsUnitId = UnitId rtsUnitName
+thisGhcUnitId = UnitId thisGhcUnitName
+interactiveUnitId = UnitId interactiveUnitName
+thUnitId = mkWiredInUnitId thUnitName
+{-# INLINE bignumUnitId #-}
+{-# INLINE baseUnitId #-}
+{-# INLINE rtsUnitId #-}
+{-# INLINE thisGhcUnitId #-}
+{-# INLINE thUnitId #-}
thUnit = RealUnit (Definite thUnitId)
primUnit = RealUnit (Definite primUnitId)
@@ -612,20 +641,28 @@ interactiveUnit = RealUnit (Definite interactiveUnitId)
-- | This is the package Id for the current program. It is the default
-- package Id if you don't specify a package name. We don't add this prefix
-- to symbol names, since there can be only one main package per program.
-mainUnitId = UnitId (fsLit "main")
+mainUnitName = fsLit "main"
+mainUnitId = UnitId mainUnitName
mainUnit = RealUnit (Definite mainUnitId)
+-- Make the actual unit id the result of looking up the wired-in unit package name in the wire map
+mkWiredInUnitId :: FastString -> UnitId
+mkWiredInUnitId x = case Map.lookup (UnitId x) $ unsafePerformIO (readIORef workingThisOut) of
+ Nothing -> pprTrace "Romes:Couldn't find UnitId" (ppr (UnitId x,unsafePerformIO (readIORef workingThisOut))) (UnitId $ fsLit "rts") -- this is a fallback, in which situations do we need a fallback? perhaps when booting the compiler with the rts?
+ Just y -> pprTrace "Romes:Found in wire map" (ppr x <+> text "->" <> ppr y) y
+
+
isInteractiveModule :: Module -> Bool
isInteractiveModule mod = moduleUnit mod == interactiveUnit
-wiredInUnitIds :: [UnitId]
-wiredInUnitIds =
- [ primUnitId
- , bignumUnitId
- , baseUnitId
- , rtsUnitId
- , thUnitId
- , thisGhcUnitId
+wiredInUnitNames :: [FastString]
+wiredInUnitNames =
+ [ primUnitName
+ , bignumUnitName
+ , baseUnitName
+ , rtsUnitName
+ , thUnitName
+ , thisGhcUnitName
]
---------------------------------------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/66cc93063f94ed3110eccd789268ee38fdc11443
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/66cc93063f94ed3110eccd789268ee38fdc11443
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/20230306/9a456081/attachment-0001.html>
More information about the ghc-commits
mailing list