Another way to fix the issuewip/t16981

There are actually many places other than FloatOut which do floating.

2 files changed, 38 insertions, 9 deletions

diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index 1bbb728de6..dc0aa58e20 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -61,7 +61,7 @@ import GHC.Builtin.PrimOps ( PrimOp (SeqOp) )
 import GHC.Builtin.Types.Prim( realWorldStatePrimTy )
 import GHC.Builtin.Names( runRWKey )
 
-import GHC.Data.Maybe   ( isNothing, orElse )
+import GHC.Data.Maybe   ( isNothing, orElse, isJust )
 import GHC.Data.FastString
 import GHC.Unit.Module ( moduleName, pprModuleName )
 import GHC.Utils.Outputable
@@ -73,6 +73,8 @@ import GHC.Utils.Monad  ( mapAccumLM, liftIO )
 import GHC.Utils.Logger
 
 import Control.Monad
+import GHC.LanguageExtensions
+import GHC.Stack.Types
 
 
 {-
@@ -666,7 +668,7 @@ tryCastWorkerWrapper env top_lvl old_bndr occ_info bndr (Cast rhs co)
            _ -> mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs work_id work_rhs
 
 tryCastWorkerWrapper env _ _ _ bndr rhs  -- All other bindings
-  = return (mkFloatBind env (NonRec bndr rhs))
+  = (mkFloatBind env (NonRec bndr rhs))
 
 mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma
 -- See Note [Cast worker/wrapper]
@@ -806,15 +808,20 @@ makeTrivialBinding :: SimplMode -> TopLevelFlag
                    -> OutType     -- Type of the expression
                    -> SimplM (LetFloats, OutId)
 makeTrivialBinding mode top_lvl occ_fs info expr expr_ty
-  = do  { (floats, expr1) <- prepareRhs mode top_lvl occ_fs expr
+  = do  { dflags <- getDynFlags
+        ; let is_static = xopt StaticPointers dflags && isJust (collectMakeStaticArgs expr)
+        ; (floats, expr1) <- prepareRhs mode top_lvl occ_fs expr
         ; uniq <- getUniqueM
-        ; let name = mkSystemVarName uniq occ_fs
-              var  = mkLocalIdWithInfo name Many expr_ty info
+        ; let var
+                | is_static = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))
+                                expr_ty
+                | otherwise = mkLocalIdWithInfo (mkSystemVarName uniq occ_fs) Many expr_ty info
 
         -- Now something very like completeBind,
         -- but without the postInlineUnconditionally part
         ; (arity_type, expr2) <- tryEtaExpandRhs mode var expr1
         ; unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs var expr2
+        ; pprTraceM "makeTrivial" (ppr floats $$ ppr expr2 $$ ppr expr1 $$ ppr expr $$ ppr is_static)
 
         ; let final_id = addLetBndrInfo var arity_type unf
               bind     = NonRec final_id expr2
@@ -896,7 +903,7 @@ completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs
  | isCoVar old_bndr
  = case new_rhs of
      Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co)
-     _           -> return (mkFloatBind env (NonRec new_bndr new_rhs))
+     _           -> (mkFloatBind env (NonRec new_bndr new_rhs))
 
  | otherwise
  = assert (isId new_bndr) $
diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs
index 6d325d02bb..17b98b29b4 100644
--- a/compiler/GHC/Core/Opt/Simplify/Env.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Env.hs
@@ -57,7 +57,7 @@ import GHC.Types.Var.Set
 import GHC.Data.OrdList
 import GHC.Types.Id as Id
 import GHC.Core.Make            ( mkWildValBinder )
-import GHC.Driver.Session       ( DynFlags )
+import GHC.Driver.Session       ( DynFlags, xopt )
 import GHC.Builtin.Types
 import GHC.Core.TyCo.Rep        ( TyCoBinder(..) )
 import qualified GHC.Core.Type as Type
@@ -74,6 +74,11 @@ import GHC.Utils.Logger
 import GHC.Types.Unique.FM      ( pprUniqFM )
 
 import Data.List (mapAccumL)
+import GHC.Utils.Trace
+import GHC.LanguageExtensions
+import Data.Maybe (isJust)
+import GHC.Types.Name
+import GHC.Data.FastString
 
 {-
 ************************************************************************
@@ -533,13 +538,26 @@ unitJoinFloat :: OutBind -> JoinFloats
 unitJoinFloat bind = assert (all isJoinId (bindersOf bind)) $
                      unitOL bind
 
-mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv)
+mkFloatBind :: HasCallStack => SimplEnv -> OutBind -> SimplM (SimplFloats, SimplEnv)
 -- Make a singleton SimplFloats, and
 -- extend the incoming SimplEnv's in-scope set with its binders
 -- These binders may already be in the in-scope set,
 -- but may have by now been augmented with more IdInfo
 mkFloatBind env bind
-  = (floats, env { seInScope = in_scope' })
+  | Just (b, expr) <- checkStaticId bind = do
+      uniq <- getUniqueM
+      let new_id = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr")) (idType b)
+          new_bind = NonRec new_id expr
+          !in_scope' = seInScope env `extendInScopeSetBind` new_bind
+          new_floats = SimplFloats { sfLetFloats  = unitLetFloat new_bind
+                      , sfJoinFloats = emptyJoinFloats
+                      , sfInScope    = in_scope' }
+
+          id_subst_env = extendIdSubst env b $
+                            DoneEx (Var new_id) Nothing
+      return (new_floats, id_subst_env { seInScope = in_scope' })
+
+  | otherwise = return (floats, env { seInScope = in_scope' })
   where
     floats
       | isJoinBind bind
@@ -553,6 +571,10 @@ mkFloatBind env bind
     -- See Note [Bangs in the Simplifier]
     !in_scope' = seInScope env `extendInScopeSetBind` bind
 
+    checkStaticId (NonRec b expr)
+      | xopt StaticPointers (seDynFlags env) && isJust (collectMakeStaticArgs expr) = Just (b, expr)
+    checkStaticId _ = Nothing
+
 extendFloats :: SimplFloats -> OutBind -> SimplFloats
 -- Add this binding to the floats, and extend the in-scope env too
 extendFloats (SimplFloats { sfLetFloats  = floats