Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC

Commits:

5 changed files:

Changes:

  • compiler/GHC/Builtin.hs
    ... ... @@ -26,11 +26,15 @@ module GHC.Builtin (
    26 26 
             knownKeyTable, knownKeyOccMap, knownKeyUniqMap,
    27 27 
             knownKeyOccName, knownKeyOccName_maybe,
    28 28
    29 
    +        -- * Known names
    30 
    +        isWiredInKnownKeyName,
    31 
    +        lookupWiredInKnownKeyName,
    32 
    +        lookupKnownNameInfo,
    33 
    +
    29 34 
             -- * Random other things
    30 35 
             maybeCharLikeCon, maybeIntLikeCon,
    31 36 
             allNameStrings, allNameStringList,
    32 37 
             itName, mkUnboundName, isUnboundName,
    33 
    -        lookupKnownNameInfo,
    34 38
    35 39 
             -- * Class categories
    36 40 
             isNumericClass, isStandardClass,
    ... ... @@ -42,6 +46,7 @@ module GHC.Builtin (
    42 46 
     import GHC.Prelude
    43 47
    44 48
    49 
    +import GHC.Builtin.Uniques
    45 50 
     import GHC.Builtin.PrimOps
    46 51 
     import GHC.Builtin.PrimOps.Ids
    47 52 
     import GHC.Builtin.WiredIn.Types
    ... ... @@ -72,6 +77,10 @@ import GHC.Data.List.SetOps
    72 77 
     import GHC.Data.FastString
    73 78 
     import qualified GHC.Data.List.Infinite as Inf
    74 79
    80 
    +import Control.Applicative ((<|>))
    81 
    +import Data.Maybe
    82 
    +
    83 
    +
    75 84
    76 85 
     {- *********************************************************************
    77 86 
     *                                                                      *
    ... ... @@ -570,11 +579,17 @@ wiredInNames
    570 579 
                             Nothing -> []
    571 580
    572 581 
     -- | Check the known-key names list of consistency.
    573 
    --- (a) Distinct uniques
    582 
    +-- (a) Unique is in-range
    583 
    +-- (b) Distinct uniques
    574 584 
     knownKeyNamesOkay :: [Name] -> Maybe SDoc
    575 585 
     knownKeyNamesOkay all_names
    576 
    -  | null badNamesPairs = Nothing
    577 
    -  | otherwise = Just badNamesDoc
    586 
    +  | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names
    587 
    +  = Just $ text "    Out-of-range known-key uniques: " <>
    588 
    +           brackets (pprWithCommas (ppr . nameOccName) ns)
    589 
    +  | null badNamesPairs
    590 
    +  = Nothing
    591 
    +  | otherwise
    592 
    +  = Just badNamesDoc
    578 593 
       where
    579 594 
         namesEnv      = foldl' (\m n -> extendNameEnv_Acc (:) Utils.singleton m n n)
    580 595 
                                emptyUFM all_names
    ... ... @@ -591,6 +606,25 @@ knownKeyNamesOkay all_names
    591 606 
                                text ": " <>
    592 607 
                                brackets (pprWithCommas (ppr . nameOccName) ns)
    593 608
    609 
    +-- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a
    610 
    +-- wired-in thing.
    611 
    +lookupWiredInKnownKeyName :: Unique -> Maybe Name
    612 
    +lookupWiredInKnownKeyName u =
    613 
    +    knownUniqueTupleName u <|> lookupUFM_Directly wiredInNamesMap u
    614 
    +
    615 
    +-- | Is a 'Name' a wired-in known-key name?
    616 
    +isWiredInKnownKeyName :: Name -> Bool
    617 
    +isWiredInKnownKeyName n =
    618 
    +    isJust (knownUniqueTupleName $ nameUnique n) || elemUFM n wiredInNamesMap
    619 
    +
    620 
    +-- | Maps 'Unique's to known-key names.
    621 
    +--
    622 
    +-- The type is @UniqFM Name Name@ to denote that the 'Unique's used
    623 
    +-- in the domain are 'Unique's associated with 'Name's (as opposed
    624 
    +-- to some other namespace of 'Unique's).
    625 
    +wiredInNamesMap :: UniqFM Name Name
    626 
    +wiredInNamesMap = listToIdentityUFM wiredInNames
    627 
    +
    594 628 
     -- | Given a 'Unique' lookup any associated arbitrary SDoc's to be displayed by
    595 629 
     -- GHCi's ':info' command.
    596 630 
     lookupKnownNameInfo :: Name -> SDoc

  • compiler/GHC/Builtin/Uniques.hs
    ... ... @@ -8,8 +8,8 @@
    8 8 
     --
    9 9
    10 10 
     module GHC.Builtin.Uniques
    11 
    -    ( -- * Looking up known-key names
    12 
    -      knownUniqueName
    11 
    +    ( -- * Looking up known-key tuples
    12 
    +      knownUniqueTupleName
    13 13
    14 14 
           -- * Getting the 'Unique's of 'Name's
    15 15 
           -- ** Anonymous sums
    ... ... @@ -73,9 +73,9 @@ import GHC.Utils.Panic
    73 73 
     import Data.Maybe
    74 74 
     import GHC.Utils.Word64 (word64ToInt)
    75 75
    76 
    --- | Get the 'Name' associated with a known-key 'Unique'.
    77 
    -knownUniqueName :: Unique -> Maybe Name
    78 
    -knownUniqueName u =
    76 
    +-- | Get the 'Name' of a tuple associated with a known-key 'Unique' with a tuple tag.
    77 
    +knownUniqueTupleName :: Unique -> Maybe Name
    78 
    +knownUniqueTupleName u =
    79 79 
         case tag of
    80 80 
           SumTag -> Just $ getUnboxedSumName n
    81 81 
           BoxedTupleTyConTag -> Just $ getTupleTyConName Boxed n

  • compiler/GHC/Builtin/Uniques.hs-boot
    ... ... @@ -2,12 +2,8 @@ module GHC.Builtin.Uniques where
    2 2
    3 3 
     import GHC.Prelude
    4 4 
     import GHC.Types.Unique
    5 
    -import {-# SOURCE #-} GHC.Types.Name
    6 5 
     import GHC.Types.Basic
    7 6
    8 
    --- Needed by GHC.Builtin.Types
    9 
    -knownUniqueName :: Unique -> Maybe Name
    10 
    -
    11 7 
     mkSumTyConUnique :: Arity -> Unique
    12 8 
     mkSumDataConUnique :: ConTagZ -> Arity -> Unique
    13 9

  • compiler/GHC/Iface/Binary.hs
    ... ... @@ -32,13 +32,14 @@ module GHC.Iface.Binary (
    32 32
    33 33 
     import GHC.Prelude
    34 34
    35 
    -import GHC.Builtin   ( knownKeyOccMap )
    35 
    +import GHC.Builtin   ( knownKeyOccMap, isWiredInKnownKeyName, lookupWiredInKnownKeyName )
    36 36 
     import GHC.Utils.Panic
    37 37 
     import GHC.Utils.Binary as Binary
    38 38 
     import GHC.Utils.Outputable
    39 39
    40 40 
     import GHC.Types.Name
    41 41 
     import GHC.Types.Unique.FM
    42 
    +import GHC.Types.Unique
    42 43 
     import GHC.Types.SrcLoc
    43 44 
     import GHC.Types.Name.Cache
    44 45
    ... ... @@ -57,6 +58,7 @@ import Control.Monad
    57 58 
     import Data.Array
    58 59 
     import Data.Array.IO
    59 60 
     import Data.Array.Unsafe
    61 
    +import Data.Char
    60 62 
     import Data.IORef
    61 63 
     import Data.Map.Strict (Map)
    62 64 
     import Data.Word
    ... ... @@ -701,11 +703,43 @@ getSymbolTable bh name_cache
    701 703 
                     ; writeArray mut_arr (fromIntegral i) name
    702 704 
                     ; return new_cache }
    703 705
    706 
    +
    707 
    +{-
    708 
    +Note [Symbol table representation of names]
    709 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    710 
    +An occurrence of a name in an interface file is serialized as a single 32-bit
    711 
    +word. The format of this word is:
    712 
    + 00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx
    713 
    +  A normal name. x is an index into the symbol table
    714 
    + 10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy
    715 
    +  A wired-in name. x is the Unique's Char, y is the int part. We assume that
    716 
    +  all wired-in known-key uniques fit in this space. This is asserted by
    717 
    +  GHC.Builtin.knownKeyNamesOkay.
    718 
    +
    719 
    +During serialization we check for tuples or wired-in things with 'isWiredInKnownKeyName'.
    720 
    +During deserialization we use 'lookupWiredInKnownKeyName' to get from the
    721 
    +unique back to its tuple or corresponding Name.
    722 
    +
    723 
    +Tuples are a special case of wired-in names that we can construct from the
    724 
    +unique alone (see 'knownUniqueTupleName'). Tuples aren't included in the
    725 
    +wired-in names map: see Note [Infinite families of known-key names].
    726 
    +-}
    727 
    +
    728 
    +
    729 
    +-- See Note [Symbol table representation of names]
    704 730 
     putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO ()
    705 731 
     putName BinSymbolTable{
    706 732 
                    bin_symtab_map = symtab_map_ref,
    707 733 
                    bin_symtab_next = symtab_next }
    708 734 
             bh name
    735 
    +  | isWiredInKnownKeyName name
    736 
    +  , let (c, u) = unpkUniqueGrimly (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
    737 
    +  = -- assert (u < 2^(22 :: Int))
    738 
    +    put_ bh (0x80000000
    739 
    +             .|. (fromIntegral (ord c) `shiftL` 22)
    740 
    +             .|. (fromIntegral u :: Word32))
    741 
    +
    742 
    +  | otherwise
    709 743 
       = do symtab_map <- readIORef symtab_map_ref
    710 744 
            case lookupUFM symtab_map name of
    711 745 
              Just (off,_) -> put_ bh (fromIntegral off :: Word32)
    ... ... @@ -717,8 +751,23 @@ putName BinSymbolTable{
    717 751 
                     $! addToUFM symtab_map name (off,name)
    718 752 
                 put_ bh (fromIntegral off :: Word32)
    719 753
    754 
    +-- See Note [Symbol table representation of names]
    720 755 
     getSymtabName :: SymbolTable Name
    721 756 
                   -> ReadBinHandle -> IO Name
    722 757 
     getSymtabName symtab bh = do
    723 758 
         i :: Word32 <- get bh
    724 
    -    return $! symtab ! fromIntegral i
    759 
    +    case i .&. 0xC0000000 of
    760 
    +      0x00000000 -> return $! symtab ! fromIntegral i
    761 
    +
    762 
    +      0x80000000 ->
    763 
    +        let
    764 
    +          tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))
    765 
    +          ix  = fromIntegral i .&. 0x003FFFFF
    766 
    +          u   = mkUniqueGrimilyWithTag tag ix
    767 
    +        in
    768 
    +          return $! case lookupWiredInKnownKeyName u of
    769 
    +                      Nothing -> pprPanic "getSymtabName:unknown known-key unique"
    770 
    +                                          (ppr i $$ ppr u $$ char tag $$ ppr ix)
    771 
    +                      Just n  -> n
    772 
    +
    773 
    +      _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)

  • libraries/ghc-internal/src/GHC/Internal/Records.hs
    ... ... @@ -32,7 +32,7 @@ module GHC.Internal.Records
    32 32
    33 33 
     import GHC.Internal.Base
    34 34 
     import GHC.Internal.Err( error )
    35 
    -import GHC.Internal.Stack.Types
    35 
    +import GHC.Internal.Stack.Types as Rebindable
    36 36
    37 37 
     -- | Constraint representing the fact that the field @x@ belongs to
    38 38 
     -- the record type @r@ and has field type @a@.  This will be solved

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help