compiler/GHC/Builtin/Names.hs

@@ -430,7 +430,6 @@ basicKnownKeyNames
         naturalPowModName,
         naturalSizeInBaseName,
 
-        bignatFromWordListName,
         bignatEqName,
 
         -- Float/Double
@@ -1203,7 +1202,6 @@ integerFromNaturalName
    , naturalLogBaseName
    , naturalPowModName
    , naturalSizeInBaseName
-   , bignatFromWordListName
    , bignatEqName
    , bignatCompareName
    , bignatCompareWordName
@@ -1215,7 +1213,6 @@ bnnVarQual str key = varQual gHC_INTERNAL_NUM_NATURAL (fsLit str) key
 bniVarQual str key = varQual gHC_INTERNAL_NUM_INTEGER (fsLit str) key
 
 -- Types and DataCons
-bignatFromWordListName    = bnbVarQual "bigNatFromWordList#"       bignatFromWordListIdKey
 bignatEqName              = bnbVarQual "bigNatEq#"                 bignatEqIdKey
 bignatCompareName         = bnbVarQual "bigNatCompare"             bignatCompareIdKey
 bignatCompareWordName     = bnbVarQual "bigNatCompareWord#"        bignatCompareWordIdKey
@@ -2641,7 +2638,6 @@ integerFromNaturalIdKey
    , naturalLogBaseIdKey
    , naturalPowModIdKey
    , naturalSizeInBaseIdKey
-   , bignatFromWordListIdKey
    , bignatEqIdKey
    , bignatCompareIdKey
    , bignatCompareWordIdKey
@@ -2709,7 +2705,6 @@ naturalLogBaseIdKey        = mkPreludeMiscIdUnique 682
 naturalPowModIdKey         = mkPreludeMiscIdUnique 683
 naturalSizeInBaseIdKey     = mkPreludeMiscIdUnique 684
 
-bignatFromWordListIdKey    = mkPreludeMiscIdUnique 690
 bignatEqIdKey              = mkPreludeMiscIdUnique 691
 bignatCompareIdKey         = mkPreludeMiscIdUnique 692
 bignatCompareWordIdKey     = mkPreludeMiscIdUnique 693

compiler/GHC/Builtin/PrimOps.hs-boot

 module GHC.Builtin.PrimOps where
 
-import GHC.Prelude ()
+-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base
+import GHC.Base ()
 
 data PrimOp

compiler/GHC/Builtin/Types/Prim.hs

@@ -63,7 +63,8 @@ module GHC.Builtin.Types.Prim(
         doublePrimTyCon,        doublePrimTy, doublePrimTyConName,
 
         statePrimTyCon,         mkStatePrimTy,
-        realWorldTyCon,         realWorldTy, realWorldStatePrimTy,
+        realWorldTyCon,         realWorldTy,
+        realWorldStatePrimTy,   realWorldMutableByteArrayPrimTy,
 
         proxyPrimTyCon,         mkProxyPrimTy,
 
@@ -1178,7 +1179,9 @@ realWorldTy :: Type
 realWorldTy          = mkTyConTy realWorldTyCon
 realWorldStatePrimTy :: Type
 realWorldStatePrimTy = mkStatePrimTy realWorldTy        -- State# RealWorld
-
+realWorldMutableByteArrayPrimTy :: Type
+realWorldMutableByteArrayPrimTy
+  = mkMutableByteArrayPrimTy realWorldTy -- MutableByteArray# RealWorld
 
 mkProxyPrimTy :: Type -> Type -> Type
 mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty]

compiler/GHC/Cmm/Dominators.hs

@@ -23,7 +23,6 @@ where
 import GHC.Prelude
 
 import Data.Array.IArray
-import Data.Foldable()
 import qualified Data.Tree as Tree
 
 import Data.Word

compiler/GHC/Core/TyCo/Subst.hs

@@ -62,7 +62,7 @@ import {-# SOURCE #-} GHC.Core.Coercion
    , mkCoercionType
    , coercionKind, coercionLKind, coVarKindsTypesRole )
 import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprTyVar )
-import {-# SOURCE #-} GHC.Core.Ppr ( )
+import {-# SOURCE #-} GHC.Core.Ppr ( ) -- instance Outputable CoreExpr
 import {-# SOURCE #-} GHC.Core ( CoreExpr )
 
 import GHC.Core.TyCo.Rep

compiler/GHC/CoreToStg/Prep.hs

@@ -14,7 +14,6 @@ module GHC.CoreToStg.Prep
    , CorePrepPgmConfig (..)
    , corePrepPgm
    , corePrepExpr
-   , mkConvertNumLiteral
    )
 where
 
@@ -24,11 +23,13 @@ import GHC.Platform
 
 import GHC.Driver.Flags
 
-import GHC.Tc.Utils.Env
 import GHC.Unit
 
 import GHC.Builtin.Names
+import GHC.Builtin.PrimOps
+import GHC.Builtin.PrimOps.Ids
 import GHC.Builtin.Types
+import GHC.Builtin.Types.Prim
 
 import GHC.Core.Utils
 import GHC.Core.Opt.Arity
@@ -60,14 +61,16 @@ import GHC.Types.Id
 import GHC.Types.Id.Info
 import GHC.Types.Id.Make ( realWorldPrimId )
 import GHC.Types.Basic
-import GHC.Types.Name   ( Name, NamedThing(..), nameSrcSpan, isInternalName )
+import GHC.Types.Name   ( NamedThing(..), nameSrcSpan, isInternalName )
 import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
 import GHC.Types.Literal
 import GHC.Types.Tickish
-import GHC.Types.TyThing
 import GHC.Types.Unique.Supply
 
-import Data.List        ( unfoldr )
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Builder as BB
+import Data.ByteString.Builder.Prim
+
 import Control.Monad
 
 {-
@@ -764,11 +767,10 @@ cpeRhsE _ (Type ty)
   = return (emptyFloats, Type ty)
 cpeRhsE _ (Coercion co)
   = return (emptyFloats, Coercion co)
-cpeRhsE env expr@(Lit (LitNumber nt i))
-   = case cp_convertNumLit (cpe_config env) nt i of
-      Nothing -> return (emptyFloats, expr)
-      Just e  -> cpeRhsE env e
-cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
+cpeRhsE env expr@(Lit lit)
+  | LitNumber LitNumBigNat i <- lit
+    = cpeBigNatLit env i
+  | otherwise = return (emptyFloats, expr)
 cpeRhsE env expr@(Var {})  = cpeApp env expr
 cpeRhsE env expr@(App {})  = cpeApp env expr
 
@@ -2240,9 +2242,7 @@ data CorePrepConfig = CorePrepConfig
   -- cases. This is helpful when debugging demand analysis or type
   -- checker bugs which can sometimes manifest as segmentation faults.
 
-  , cp_convertNumLit           :: !(LitNumType -> Integer -> Maybe CoreExpr)
-  -- ^ Convert some numeric literals (Integer, Natural) into their final
-  -- Core form.
+  , cp_platform                :: Platform
 
   , cp_arityOpts               :: !(Maybe ArityOpts)
   -- ^ Configuration for arity analysis ('exprEtaExpandArity').
@@ -2442,57 +2442,119 @@ wrapTicks floats expr
 -- Numeric literals
 -- ---------------------------------------------------------------------------
 
--- | Create a function that converts Bignum literals into their final CoreExpr
-mkConvertNumLiteral
-   :: Platform
-   -> HomeUnit
-   -> (Name -> IO TyThing)
-   -> IO (LitNumType -> Integer -> Maybe CoreExpr)
-mkConvertNumLiteral platform home_unit lookup_global = do
-   let
-      guardBignum act
-         | isHomeUnitInstanceOf home_unit primUnitId
-         = return $ panic "Bignum literals are not supported in ghc-prim"
-         | isHomeUnitInstanceOf home_unit bignumUnitId
-         = return $ panic "Bignum literals are not supported in ghc-bignum"
-         | otherwise = act
-
-      lookupBignumId n      = guardBignum (tyThingId <$> lookup_global n)
-
-   -- The lookup is done here but the failure (panic) is reported lazily when we
-   -- try to access the `bigNatFromWordList` function.
-   --
-   -- If we ever get built-in ByteArray# literals, we could avoid the lookup by
-   -- directly using the Integer/Natural wired-in constructors for big numbers.
-
-   bignatFromWordListId <- lookupBignumId bignatFromWordListName
-
-   let
-      convertNumLit nt i = case nt of
-         LitNumBigNat  -> Just (convertBignatPrim i)
-         _             -> Nothing
-
-      convertBignatPrim i =
-         let
-            -- ByteArray# literals aren't supported (yet). Were they supported,
-            -- we would use them directly. We would need to handle
-            -- wordSize/endianness conversion between host and target
-            -- wordSize  = platformWordSize platform
-            -- byteOrder = platformByteOrder platform
-
-            -- For now we build a list of Words and we produce
-            -- `bigNatFromWordList# list_of_words`
-
-            words = mkListExpr wordTy (reverse (unfoldr f i))
-               where
-                  f 0 = Nothing
-                  f x = let low  = x .&. mask
-                            high = x `shiftR` bits
-                        in Just (mkConApp wordDataCon [Lit (mkLitWord platform low)], high)
-                  bits = platformWordSizeInBits platform
-                  mask = 2 ^ bits - 1
-
-         in mkApps (Var bignatFromWordListId) [words]
-
-
-   return convertNumLit
+-- | Converts Bignum literals into their final CoreExpr
+cpeBigNatLit
+   :: CorePrepEnv -> Integer -> UniqSM (Floats, CpeRhs)
+cpeBigNatLit env i = assert (i >= 0) $ do
+  let
+    platform = cp_platform (cpe_config env)
+
+    -- Per the documentation in GHC.Num.BigNat, a BigNat# is:
+    --   "Represented as an array of limbs (Word#) stored in
+    --   little-endian order (Word# themselves use machine order)."
+    --
+    --   "Invariant (canonical representation): higher Word# is non-zero."
+    -- So we need to break up the integer into target-word-sized chunks,
+    -- and encode each of them using the target's byte-order.
+    encodeBigNat
+      :: forall a. Num a => FixedPrim a -> BS.ByteString
+    encodeBigNat encodeWord
+      = BS.toStrict (BB.toLazyByteString (primUnfoldrFixed encodeWord f i))
+      -- (quadratic complexity due to repeated shifts... ok for now)
+      where
+        f 0 = Nothing
+        f x = let low  = fromInteger x :: a
+                  high = x `shiftR` bits
+              in Just (low, high)
+        bits = platformWordSizeInBits platform
+
+    words :: BS.ByteString
+    words = case (platformWordSize platform, platformByteOrder platform) of
+      (PW4, LittleEndian) -> encodeBigNat word32LE
+      (PW4, BigEndian   ) -> encodeBigNat word32BE
+      (PW8, LittleEndian) -> encodeBigNat word64LE
+      (PW8, BigEndian   ) -> encodeBigNat word64BE
+
+  -- Ideally we would just generate a ByteArray# literal here:
+  --   pure (emptyFloats, Lit (LitByteArray words))
+  -- But sadly we don't have those yet, even in Core. (See also #17747.)
+  -- So instead we generate:
+  --   * An `Addr#` literal that contains the contents of the
+  --      `ByteArray#` we want to create.  This gets its own float.
+  --   * A call to `newByteArray#` with the appropriate size
+  --   * A call to `copyAddrToByteArray#` to initialize the `ByteArray#`
+  --   * A call to `unsafeFreezeByteArray#` to make the types match
+  litAddrId <- mkSysLocalM (fsLit "bigNatGuts") ManyTy addrPrimTy
+  -- returned from newByteArray#:
+  deadNewByteArrayTupleId
+    <- fmap (`setIdOccInfo` IAmDead) . mkSysLocalM (fsLit "tup") ManyTy $
+         mkTupleTy Unboxed [ realWorldStatePrimTy
+                           , realWorldMutableByteArrayPrimTy
+                           ]
+  stateTokenFromNewByteArrayId
+    <- mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy
+  mutableByteArrayId
+    <- mkSysLocalM (fsLit "mba") ManyTy realWorldMutableByteArrayPrimTy
+  -- returned from copyAddrToByteArray#:
+  stateTokenFromCopyId
+    <- mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy
+  -- returned from unsafeFreezeByteArray#:
+  deadFreezeTupleId
+    <- fmap (`setIdOccInfo` IAmDead) . mkSysLocalM (fsLit "tup") ManyTy $
+         mkTupleTy Unboxed [realWorldStatePrimTy, byteArrayPrimTy]
+  stateTokenFromFreezeId
+    <- (`setIdOccInfo` IAmDead) <$>
+         mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy
+  byteArrayId <- mkSysLocalM (fsLit "ba") ManyTy byteArrayPrimTy
+
+  let
+    litAddrRhs = Lit (LitString words)
+      -- not "mkLitString"; that does UTF-8 encoding, which we don't want here
+    litAddrFloat = mkNonRecFloat env topDmd True litAddrId litAddrRhs
+
+    contentsLength = mkIntLit platform (toInteger (BS.length words))
+
+    newByteArrayCall =
+      Var (primOpId NewByteArrayOp_Char)
+        `App` Type realWorldTy
+        `App` contentsLength
+        `App` Var realWorldPrimId
+
+    copyContentsCall =
+      Var (primOpId CopyAddrToByteArrayOp)
+        `App` Type realWorldTy
+        `App` Var litAddrId
+        `App` Var mutableByteArrayId
+        `App` mkIntLit platform 0
+        `App` contentsLength
+        `App` Var stateTokenFromNewByteArrayId
+
+    unsafeFreezeCall =
+      Var (primOpId UnsafeFreezeByteArrayOp)
+        `App` Type realWorldTy
+        `App` Var mutableByteArrayId
+        `App` Var stateTokenFromCopyId
+
+    unboxed2tuple_altcon :: AltCon
+    unboxed2tuple_altcon = DataAlt (tupleDataCon Unboxed 2)
+
+    finalRhs =
+      Case newByteArrayCall deadNewByteArrayTupleId byteArrayPrimTy
+        [ Alt unboxed2tuple_altcon
+              [stateTokenFromNewByteArrayId, mutableByteArrayId]
+              copyContentsCase
+        ]
+
+    copyContentsCase =
+      Case copyContentsCall stateTokenFromCopyId byteArrayPrimTy
+        [ Alt DEFAULT [] unsafeFreezeCase
+        ]
+
+    unsafeFreezeCase =
+      Case unsafeFreezeCall deadFreezeTupleId byteArrayPrimTy
+        [ Alt unboxed2tuple_altcon
+              [stateTokenFromFreezeId, byteArrayId]
+              (Var byteArrayId)
+        ]
+
+  pure (emptyFloats `snocFloat` litAddrFloat, finalRhs)

compiler/GHC/Data/Word64Map/Strict.hs

@@ -248,4 +248,3 @@ module GHC.Data.Word64Map.Strict (
     ) where
 
 import GHC.Data.Word64Map.Strict.Internal
-import Prelude ()

compiler/GHC/Driver/CmdLine.hs

@@ -31,7 +31,7 @@ import GHC.Types.SrcLoc
 import GHC.Types.Error
 import GHC.Utils.Error
 import GHC.Driver.Errors.Types
-import GHC.Driver.Errors.Ppr ()
+import GHC.Driver.Errors.Ppr () -- instance Diagnostic DriverMessage
 import GHC.Utils.Outputable (text)
 
 import Data.Function

compiler/GHC/Driver/Config/CoreToStg/Prep.hs

@@ -10,7 +10,6 @@ import GHC.Driver.Env
 import GHC.Driver.Session
 import GHC.Driver.Config.Core.Lint
 import GHC.Driver.Config.Core.Opt.Arity
-import GHC.Tc.Utils.Env
 import GHC.Types.Var
 import GHC.Utils.Outputable ( alwaysQualify )
 
@@ -19,14 +18,9 @@ import GHC.CoreToStg.Prep
 initCorePrepConfig :: HscEnv -> IO CorePrepConfig
 initCorePrepConfig hsc_env = do
    let dflags = hsc_dflags hsc_env
-   convertNumLit <- do
-     let platform = targetPlatform dflags
-         home_unit = hsc_home_unit hsc_env
-         lookup_global = lookupGlobal hsc_env
-     mkConvertNumLiteral platform home_unit lookup_global
    return $ CorePrepConfig
       { cp_catchNonexhaustiveCases = gopt Opt_CatchNonexhaustiveCases dflags
-      , cp_convertNumLit = convertNumLit
+      , cp_platform  = targetPlatform dflags
       , cp_arityOpts = if gopt Opt_DoCleverArgEtaExpansion dflags
                        then Just (initArityOpts dflags)
                        else Nothing

compiler/GHC/Driver/Config/Diagnostic.hs

@@ -19,7 +19,7 @@ import GHC.Prelude
 import GHC.Utils.Outputable
 import GHC.Utils.Error (DiagOpts (..))
 import GHC.Driver.Errors.Types (GhcMessage, GhcMessageOpts (..), PsMessage, DriverMessage, DriverMessageOpts (..), checkBuildingCabalPackage)
-import GHC.Driver.Errors.Ppr ()
+import GHC.Driver.Errors.Ppr () -- Diagnostic instances
 import GHC.Tc.Errors.Types
 import GHC.HsToCore.Errors.Types
 import GHC.Types.Error

compiler/GHC/Driver/Errors/Ppr.hs

@@ -14,8 +14,8 @@ import GHC.Prelude
 import GHC.Driver.Errors.Types
 import GHC.Driver.Flags
 import GHC.Driver.DynFlags
-import GHC.HsToCore.Errors.Ppr ()
-import GHC.Parser.Errors.Ppr ()
+import GHC.HsToCore.Errors.Ppr () -- instance Diagnostic DsMessage
+import GHC.Parser.Errors.Ppr () -- instance Diagnostic PsMessage
 import GHC.Types.Error
 import GHC.Types.Error.Codes
 import GHC.Unit.Types
@@ -30,8 +30,8 @@ import Language.Haskell.Syntax.Decls (RuleDecl(..))
 import GHC.Tc.Errors.Types (TcRnMessage)
 import GHC.HsToCore.Errors.Types (DsMessage)
 import GHC.Iface.Errors.Types
-import GHC.Tc.Errors.Ppr ()
-import GHC.Iface.Errors.Ppr ()
+import GHC.Tc.Errors.Ppr () -- instance Diagnostic TcRnMessage
+import GHC.Iface.Errors.Ppr () -- instance Diagnostic IfaceMessage
 
 --
 -- Suggestions

compiler/GHC/Iface/Errors/Ppr.hs

@@ -7,7 +7,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 
-{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic IfaceMessage
 {-# LANGUAGE InstanceSigs #-}
 
 module GHC.Iface.Errors.Ppr

compiler/GHC/Iface/Syntax.hs

@@ -85,7 +85,7 @@ import GHC.Hs.Doc ( WithHsDocIdentifiers(..) )
 import GHC.Utils.Lexeme (isLexSym)
 import GHC.Utils.Fingerprint
 import GHC.Utils.Binary
-import GHC.Utils.Binary.Typeable ()
+import GHC.Utils.Binary.Typeable () -- instance Binary AnnPayload
 import GHC.Utils.Outputable as Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith,

compiler/GHC/Iface/Type.hs-boot

@@ -6,7 +6,7 @@ module GHC.Iface.Type
 where
 
 -- Empty import to influence the compilation ordering.
--- See Note [Depend on GHC.Num.Integer] in GHC.Base
+-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base
 import GHC.Base ()
 
 data IfaceAppArgs

compiler/GHC/Parser/PostProcess.hs

@@ -139,7 +139,6 @@ import GHC.Types.SourceText
 import GHC.Parser.Types
 import GHC.Parser.Lexer
 import GHC.Parser.Errors.Types
-import GHC.Parser.Errors.Ppr ()
 import GHC.Utils.Lexeme ( okConOcc )
 import GHC.Types.TyThing
 import GHC.Core.Type    ( Specificity(..) )

compiler/GHC/Platform.hs

@@ -79,7 +79,7 @@ data Platform = Platform
    , platformTablesNextToCode         :: !Bool
       -- ^ Determines whether we will be compiling info tables that reside just
       --   before the entry code, or with an indirection to the entry code. See
-      --   TABLES_NEXT_TO_CODE in rts/include/rts/storage/InfoTables.h.
+      --   TABLES_NEXT_TO_CODE in @rts/include/rts/storage/InfoTables.h@.
    , platformHasLibm                  :: !Bool
       -- ^ Some platforms require that we explicitly link against @libm@ if any
       -- math-y things are used (which we assume to include all programs). See

compiler/GHC/StgToJS/Types.hs

@@ -26,7 +26,7 @@ import GHC.JS.JStg.Syntax
 import GHC.JS.Ident
 import qualified GHC.JS.Syntax as Sat
 import GHC.JS.Make
-import GHC.JS.Ppr ()
+import GHC.JS.Ppr () -- expose Outputable instances to downstream modules
 
 import GHC.Stg.Syntax
 import GHC.Core.TyCon

compiler/GHC/Tc/Errors/Hole/Plugin.hs-boot

 module GHC.Tc.Errors.Hole.Plugin where
 
-data HoleFitPlugin
\ No newline at end of file
+-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base
+import GHC.Base ()
+
+data HoleFitPlugin

compiler/GHC/Tc/Types/LclEnv.hs-boot

 module GHC.Tc.Types.LclEnv where
 
-data TcLclEnv
\ No newline at end of file
+-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base
+import GHC.Base ()
+
+data TcLclEnv

compiler/GHC/Tc/Utils/Env.hs

@@ -888,7 +888,7 @@ tcGetDefaultTys
 
 {-
 Note [Extended defaults]
-~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~
 In interactive mode (or with -XExtendedDefaultRules) we add () as the first type we
 try when defaulting.  This has very little real impact, except in the following case.
 Consider: