Move 'nextWrapperNum' into 'DsM' and 'TcM'

Previously existing in 'DynFlags', 'nextWrapperNum' is a global
variable mapping a Module to a number for name generation for FFI calls.

This is not the right location for 'nextWrapperNum', as 'DynFlags'
should not contain just about any global variable.

7 files changed, 34 insertions, 22 deletions

diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 9b6ee1b626..26ae0c6e0d 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -641,8 +641,6 @@ data DynFlags = DynFlags {
 
   interactivePrint      :: Maybe String,
 
-  nextWrapperNum        :: IORef (ModuleEnv Int),
-
   -- | Machine dependent flags (-m\<blah> stuff)
   sseVersion            :: Maybe SseVersion,
   bmiVersion            :: Maybe BmiVersion,
@@ -1049,7 +1047,6 @@ initDynFlags dflags = do
  refDynamicTooFailed <- newIORef (not platformCanGenerateDynamicToo)
  refRtldInfo <- newIORef Nothing
  refRtccInfo <- newIORef Nothing
- wrapperNum <- newIORef emptyModuleEnv
  canUseUnicode <- do let enc = localeEncoding
                          str = "‘’"
                      (withCString enc str $ \cstr ->
@@ -1067,7 +1064,6 @@ initDynFlags dflags = do
        (useColor dflags, colScheme dflags)
  return dflags{
         dynamicTooFailed = refDynamicTooFailed,
-        nextWrapperNum = wrapperNum,
         useUnicode    = useUnicode',
         useColor      = useColor',
         canUseColor   = stderrSupportsAnsiColors,
@@ -1230,7 +1226,6 @@ defaultDynFlags mySettings llvmConfig =
         profAuto = NoProfAuto,
         callerCcFilters = [],
         interactivePrint = Nothing,
-        nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum",
         sseVersion = Nothing,
         bmiVersion = Nothing,
         avx = False,
diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs
index ba7cd74a89..10eee59112 100644
--- a/compiler/GHC/HsToCore/Foreign/Decl.hs
+++ b/compiler/GHC/HsToCore/Foreign/Decl.hs
@@ -23,6 +23,7 @@ import GHC.Core
 
 import GHC.HsToCore.Foreign.Call
 import GHC.HsToCore.Monad
+import GHC.HsToCore.Types (ds_next_wrapper_num)
 
 import GHC.Hs
 import GHC.Core.DataCon
@@ -229,12 +230,12 @@ dsFCall fn_id co fcall mDeclHeader = do
     ccall_uniq <- newUnique
     work_uniq  <- newUnique
 
-    dflags <- getDynFlags
     (fcall', cDoc) <-
               case fcall of
               CCall (CCallSpec (StaticTarget _ cName mUnitId isFun)
                                CApiConv safety) ->
-               do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)
+               do nextWrapperNum <- ds_next_wrapper_num <$> getGblEnv
+                  wrapperName <- mkWrapperName nextWrapperNum "ghc_wrapper" (unpackFS cName)
                   let fcall' = CCall (CCallSpec
                                       (StaticTarget NoSourceText
                                                     wrapperName mUnitId
@@ -278,6 +279,7 @@ dsFCall fn_id co fcall mDeclHeader = do
                   return (fcall', c)
               _ ->
                   return (fcall, empty)
+    dflags <- getDynFlags
     let
         -- Build the worker
         worker_ty     = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty)
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index a16f70cded..788f4828e2 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -236,8 +236,10 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
              complete_matches = hptCompleteSigs hsc_env         -- from the home package
                                 ++ tcg_complete_matches tcg_env -- from the current module
                                 ++ eps_complete_matches eps     -- from imports
+             -- re-use existing next_wrapper_num to ensure uniqueness
+             next_wrapper_num_var = tcg_next_wrapper_num tcg_env
        ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env
-                           msg_var cc_st_var complete_matches
+                           msg_var cc_st_var next_wrapper_num_var complete_matches
        }
 
 runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DiagnosticMessage, Maybe a)
@@ -261,6 +263,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
                                    , mg_complete_matches = local_complete_matches
                           }) thing_inside
   = do { cc_st_var   <- newIORef newCostCentreState
+       ; next_wrapper_num <- newIORef emptyModuleEnv
        ; msg_var <- newIORef emptyMessages
        ; eps <- liftIO $ hscEPS hsc_env
        ; let unit_env = hsc_unit_env hsc_env
@@ -275,7 +278,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
 
              envs  = mkDsEnvs unit_env this_mod rdr_env type_env
                               fam_inst_env msg_var cc_st_var
-                              complete_matches
+                              next_wrapper_num complete_matches
        ; runDs hsc_env envs thing_inside
        }
 
@@ -313,10 +316,11 @@ initTcDsForSolver thing_inside
            Nothing  -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLoc (getErrorMessages msgs)) }
 
 mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-         -> IORef (Messages DiagnosticMessage) -> IORef CostCentreState -> CompleteMatches
+         -> IORef (Messages DiagnosticMessage) -> IORef CostCentreState
+         -> IORef (ModuleEnv Int) -> CompleteMatches
          -> (DsGblEnv, DsLclEnv)
 mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var
-         complete_matches
+         next_wrapper_num complete_matches
   = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs",
                              if_rec_types = Just (mod, return type_env) }
         if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
@@ -330,6 +334,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var
                            , ds_msgs    = msg_var
                            , ds_complete_matches = complete_matches
                            , ds_cc_st   = cc_st_var
+                           , ds_next_wrapper_num = next_wrapper_num
                            }
         lcl_env = DsLclEnv { dsl_meta    = emptyNameEnv
                            , dsl_loc     = real_span
diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs
index aa3e097c0d..58273e250e 100644
--- a/compiler/GHC/HsToCore/Types.hs
+++ b/compiler/GHC/HsToCore/Types.hs
@@ -6,6 +6,8 @@ module GHC.HsToCore.Types (
         DsMetaEnv, DsMetaVal(..), CompleteMatches
     ) where
 
+import GHC.Prelude (Int)
+
 import Data.IORef
 
 import GHC.Types.CostCentre.State
@@ -54,6 +56,8 @@ data DsGblEnv
      -- Additional complete pattern matches
   , ds_cc_st   :: IORef CostCentreState
      -- Tracking indices for cost centre annotations
+  , ds_next_wrapper_num :: IORef (ModuleEnv Int)
+    -- ^ See Note [Generating fresh names for FFI wrappers]
   }
 
 instance ContainsModule DsGblEnv where
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index 94d454055e..40cdf54d12 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -579,7 +579,10 @@ data TcGblEnv
         tcg_complete_matches :: !CompleteMatches,
 
         -- ^ Tracking indices for cost centre annotations
-        tcg_cc_st   :: TcRef CostCentreState
+        tcg_cc_st   :: TcRef CostCentreState,
+
+        tcg_next_wrapper_num :: TcRef (ModuleEnv Int)
+        -- ^ See Note [Generating fresh names for FFI wrappers]
     }
 
 -- NB: topModIdentity, not topModSemantic!
diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
index 7ffd2f2f2c..cf0f1b706b 100644
--- a/compiler/GHC/Tc/Utils/Env.hs
+++ b/compiler/GHC/Tc/Utils/Env.hs
@@ -1086,7 +1086,8 @@ mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM
 mkStableIdFromString str sig_ty loc occ_wrapper = do
     uniq <- newUnique
     mod <- getModule
-    name <- mkWrapperName "stable" str
+    nextWrapperNum <- tcg_next_wrapper_num <$> getGblEnv
+    name <- mkWrapperName nextWrapperNum "stable" str
     let occ = mkVarOccFS name :: OccName
         gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name
         id  = mkExportedVanillaId gnm sig_ty :: Id
@@ -1095,14 +1096,14 @@ mkStableIdFromString str sig_ty loc occ_wrapper = do
 mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
 mkStableIdFromName nm = mkStableIdFromString (getOccString nm)
 
-mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m)
-              => String -> String -> m FastString
-mkWrapperName what nameBase
-    = do dflags <- getDynFlags
-         thisMod <- getModule
-         let -- Note [Generating fresh names for ccall wrapper]
-             wrapperRef = nextWrapperNum dflags
-             pkg = unitString  (moduleUnit thisMod)
+mkWrapperName :: (MonadIO m, HasModule m)
+              => IORef (ModuleEnv Int) -> String -> String -> m FastString
+-- ^ @mkWrapperName ref what nameBase@
+--
+-- See Note [Generating fresh names for ccall wrapper] for @ref@'s purpose.
+mkWrapperName wrapperRef what nameBase
+    = do thisMod <- getModule
+         let pkg = unitString  (moduleUnit thisMod)
              mod = moduleNameString (moduleName      thisMod)
          wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env ->
              let num = lookupWithDefaultModuleEnv mod_env 0 thisMod
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index fb613c8f8d..5568e34b75 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -260,6 +260,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
         th_state_var         <- newIORef Map.empty ;
         th_remote_state_var  <- newIORef Nothing ;
         th_docs_var          <- newIORef Map.empty ;
+        next_wrapper_num     <- newIORef emptyModuleEnv ;
         let {
              -- bangs to avoid leaking the env (#19356)
              !dflags = hsc_dflags hsc_env ;
@@ -347,7 +348,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_top_loc        = loc,
                 tcg_static_wc      = static_wc_var,
                 tcg_complete_matches = [],
-                tcg_cc_st          = cc_st_var
+                tcg_cc_st          = cc_st_var,
+                tcg_next_wrapper_num = next_wrapper_num
              } ;
         } ;