Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC

Commits:

7 changed files:

Changes:

  • compiler/GHC/Builtin/Names.hs
    ... ... @@ -654,7 +654,7 @@ mkInteractiveModule n = mkModule interactiveUnit (mkModuleName ("Ghci" ++ n))
    654 654 
     pRELUDE_NAME, mAIN_NAME, kNOWN_KEY_NAMES :: ModuleName
    655 655 
     pRELUDE_NAME    = mkModuleNameFS (fsLit "Prelude")
    656 656 
     mAIN_NAME       = mkModuleNameFS (fsLit "Main")
    657 
    -kNOWN_KEY_NAMES = mkModuleNameFS (fsLit "KnownKeyNames")
    657 
    +kNOWN_KEY_NAMES = mkModuleNameFS (fsLit "GHC.KnownKeyNames")
    658 658
    659 659
    660 660 
     mkGhcInternalModule :: FastString -> Module

  • compiler/GHC/Driver/DynFlags.hs
    ... ... @@ -1383,6 +1383,7 @@ languageExtensions Nothing = languageExtensions (Just defaultLanguage)
    1383 1383
    1384 1384 
     languageExtensions (Just Haskell98)
    1385 1385 
         = [LangExt.ImplicitPrelude,
    1386 
    +       LangExt.ImplicitKnownKeyNames,
    1386 1387 
            -- See Note [When is StarIsType enabled]
    1387 1388 
            LangExt.StarIsType,
    1388 1389 
            LangExt.CUSKs,
    ... ... @@ -1405,6 +1406,7 @@ languageExtensions (Just Haskell98)
    1405 1406
    1406 1407 
     languageExtensions (Just Haskell2010)
    1407 1408 
         = [LangExt.ImplicitPrelude,
    1409 
    +       LangExt.ImplicitKnownKeyNames,
    1408 1410 
            -- See Note [When is StarIsType enabled]
    1409 1411 
            LangExt.StarIsType,
    1410 1412 
            LangExt.CUSKs,
    ... ... @@ -1424,6 +1426,7 @@ languageExtensions (Just Haskell2010)
    1424 1426
    1425 1427 
     languageExtensions (Just GHC2021)
    1426 1428 
         = [LangExt.ImplicitPrelude,
    1429 
    +       LangExt.ImplicitKnownKeyNames,
    1427 1430 
            -- See Note [When is StarIsType enabled]
    1428 1431 
            LangExt.StarIsType,
    1429 1432 
            LangExt.MonomorphismRestriction,

  • compiler/GHC/Iface/Env.hs
    ... ... @@ -44,7 +44,7 @@ import GHC.Types.SrcLoc
    44 44 
     import GHC.Types.Unique
    45 45
    46 46 
     import GHC.Utils.Misc( HasDebugCallStack )
    47 
    -import GHC.Utils.Panic( callStackDoc )
    47 
    +import GHC.Utils.Panic
    48 48 
     import GHC.Utils.Outputable
    49 49 
     import GHC.Utils.Error
    50 50 
     import GHC.Utils.Logger
    ... ... @@ -76,7 +76,7 @@ newGlobalBinder mod occ mb_uniq loc
    76 76 
       = do { hsc_env <- getTopEnv
    77 77 
            ; name <- liftIO $ allocateGlobalBinder (hsc_NC hsc_env) mod occ mb_uniq loc
    78 78 
            ; traceIf (text "newGlobalBinder" <+>
    79 
    -                  vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name, callStackDoc])
    79 
    +                  vcat [ ppr mod <+> ppr occ <+> ppr loc <+> ppr mb_uniq, ppr name, callStackDoc])
    80 80 
            ; return name }
    81 81
    82 82 
     newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name
    ... ... @@ -113,11 +113,13 @@ allocateGlobalBinder nc mod occ mb_uniq loc
    113 113 
             Just name | isWiredInName name
    114 114 
                       -> pure (cache0, name)
    115 115 
                       | otherwise
    116 
    -                  -> warnPprTrace wrong_unique "allocateGlobalBinder" (ppr mb_uniq $$ ppr name) $
    116 
    +                  -> assertPpr (not wrong_unique)
    117 
    +                               (hang (text "allocateGlobalBinder:bad known-key unique")
    118 
    +                                   2 (ppr mb_uniq $$ ppr name)) $
    117 119 
                          pure (new_cache, name')
    118 120 
                       where
    119 121 
                         uniq      = nameUnique name
    120 
    -                    name'     = mkExternalName uniq mod occ loc
    122 
    +                    name'     = setNameLoc name loc
    121 123 
                                     -- name' is like name, but with the right SrcSpan
    122 124 
                         new_cache = extendOrigNameCache cache0 mod occ name'
    123 125 
                         wrong_unique = case mb_uniq of
    ... ... @@ -126,13 +128,12 @@ allocateGlobalBinder nc mod occ mb_uniq loc
    126 128
    127 129 
             -- Miss in the cache!
    128 130 
             -- Build a completely new Name, and put it in the cache
    129 
    -        _ -> do
    130 
    -              uniq <- case mb_uniq of
    131 
    -                        Just uniq -> return uniq
    132 
    -                        Nothing   -> takeUniqFromNameCache nc
    133 
    -              let name      = mkExternalName uniq mod occ loc
    134 
    -              let new_cache = extendOrigNameCache cache0 mod occ name
    135 
    -              pure (new_cache, name)
    131 
    +        _ -> do { name <- case mb_uniq of
    132 
    +                             Just uniq -> return (mkKnownKeyName uniq mod occ loc)
    133 
    +                             Nothing -> do { uniq <- takeUniqFromNameCache nc
    134 
    +                                           ; return (mkExternalName uniq mod occ loc) }
    135 
    +                ; let new_cache = extendOrigNameCache cache0 mod occ name
    136 
    +                ; pure (new_cache, name) }
    136 137
    137 138 
     ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
    138 139 
     ifaceExportNames exports = return exports

  • compiler/GHC/Iface/Load.hs
    ... ... @@ -139,14 +139,19 @@ lookupKnownKeyThing :: HasDebugCallStack
    139 139 
     lookupKnownKeyThing Nothing uniq
    140 140 
       = do { known_key_name_map <- loadKnownKeyOccMap
    141 141 
            ; let name = lookupUFM known_key_name_map uniq
    142 
    -                    `orElse` pprPanic "lookupKnownKeyThing" (ppr uniq)
    142 
    +                    `orElse` pprPanic "lookupKnownKeyThing" (ppr uniq $$ ppr known_key_name_map)
    143 
    +       ; traceIf $ hang (text "lookupKnownKeyThing ImplicitKnownKeyNames")
    144 
    +                      2 (ppr name <+> ppr uniq)
    143 145 
            ; lookupGlobalName name }
    144 146
    145 147 
     lookupKnownKeyThing (Just gbl_rdr_env) uniq
    146 148 
       -- Look up the known-key OccName in the current top-level GlobalRdrEnv
    147 149 
       -- If we get a unique hit, use it; if not, panic.
    148 150 
       = case lookupGRE gbl_rdr_env (LookupOccName occ SameNameSpace) of
    149 
    -       [gre] -> lookupGlobalName (greName gre)
    151 
    +       [gre] -> do { let name = greName gre
    152 
    +                   ; traceIf $ hang (text "lookupKnownKeyThing NoImplicitKnownKeyNames")
    153 
    +                                  2 (ppr name <+> ppr uniq)
    154 
    +                   ; lookupGlobalName name }
    150 155 
            gres  -> pprPanic "lookupKnownKeyOcc" (ppr occ $$ ppr gres)
    151 156 
       where
    152 157 
          occ = lookupUFM knownKeyUniqMap uniq
    ... ... @@ -321,8 +326,7 @@ importDecl name
    321 326 
             { eps <- getEps
    322 327 
             ; case lookupTypeEnv (eps_PTE eps) name of
    323 328 
                 Just thing -> return $ Succeeded thing
    324 
    -            Nothing    -> pprTrace "importDecl" (ppr name $$ callStackDoc) $
    325 
    -                          return $ Failed $
    329 
    +            Nothing    -> return $ Failed $
    326 330 
                   Can'tFindNameInInterface name
    327 331 
                   (filter is_interesting $ nonDetNameEnvElts $ eps_PTE eps)
    328 332 
         }}}
    ... ... @@ -637,6 +641,8 @@ loadInterface doc_str mod from
    637 641 
             -- Crucial assertion that checks if you are trying to load a HPT module into the EPS.
    638 642 
             -- If you start loading HPT modules into the EPS then you get strange errors about
    639 643 
             -- overlapping instances.
    644 
    +        ; traceIf (hang (text "Loaded new interface" <+> ppr mod)
    645 
    +                      2 (ppr (mi_exports iface)))
    640 646 
             ; massertPpr
    641 647 
                   ((isOneShot (ghcMode (hsc_dflags hsc_env)))
    642 648 
                     || moduleUnitId mod `notElem` hsc_all_home_unit_ids hsc_env

  • compiler/GHC/Types/Name.hs
    ... ... @@ -753,8 +753,8 @@ pprName_userQual user_qual name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ
    753 753 
          sdocOption sdocListTuplePuns $ \listTuplePuns ->
    754 754 
            handlePuns listTuplePuns (namePun_maybe name) $
    755 755 
            case sort of
    756 
    -         WiredIn mod _ bi -> pprExternal debug sty uniq mod user_qual occ (text "(w)")  bi
    757 
    -         External mod     -> pprExternal debug sty uniq mod user_qual occ empty UserSyntax
    756 
    +         WiredIn mod _ bi -> pprExternal debug sty uniq mod user_qual occ (text "(w)") bi
    757 
    +         External mod     -> pprExternal debug sty uniq mod user_qual occ (text "(x)") UserSyntax
    758 758 
              KnownKey mod     -> pprExternal debug sty uniq mod user_qual occ (text "(k)") UserSyntax
    759 759 
              System           -> pprSystem   debug sty uniq occ
    760 760 
              Internal         -> pprInternal debug sty uniq occ

  • libraries/base/src/Prelude.hs
    ... ... @@ -183,3 +183,4 @@ import GHC.Internal.Num
    183 183 
     import GHC.Internal.Real
    184 184 
     import GHC.Internal.Float
    185 185 
     import GHC.Internal.Show
    186 
    +

  • libraries/ghc-internal/src/GHC/Internal/Real.hs-boot
    1 1 
     {-# LANGUAGE NoImplicitPrelude #-}
    2 
    +{-# LANGUAGE DefinesKnownKeyNames #-}
    2 3
    3 4 
     module GHC.Internal.Real (Integral (..)) where
    4 5

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