Stop the simplifier from removing StaticPtr binds.

Summary:
We have the FloatOut pass create exported ids for floated StaticPtr
bindings. The simplifier doesn't try to remove those.

This patch also improves on 7fc20b by making a common definition
collectStaticPtrSatArgs to test for StaticPtr binds.

Fixes #12207.

Test Plan: ./validate

Reviewers: simonpj, austin, bgamari, simonmar, goldfire

Reviewed By: simonpj

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2366

GHC Trac Issues: #12207

2 files changed, 28 insertions, 5 deletions

diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index e7acafc2bb..73e93eaf35 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -552,10 +552,7 @@ lintRhs :: CoreExpr -> LintM OutType
 -- but produce errors otherwise.
 lintRhs rhs
     | (binders0, rhs') <- collectTyBinders rhs
-    , (fun@(Var b), args, _) <- collectArgsTicks (const True) rhs'
-    , Just con <- isDataConId_maybe b
-    , dataConName con == staticPtrDataConName
-    , length args == 5
+    , Just (fun, args) <- collectStaticPtrSatArgs rhs'
     = flip fix binders0 $ \loopBinders binders -> case binders of
         -- imitate @lintCoreExpr (Lam ...)@
         var : vars -> addLoc (LambdaBodyOf var) $
diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index aeb0afbc69..f11c6bef04 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -45,12 +45,16 @@ module CoreUtils (
 
         -- * Working with ticks
         stripTicksTop, stripTicksTopE, stripTicksTopT,
-        stripTicksE, stripTicksT
+        stripTicksE, stripTicksT,
+
+        -- * StaticPtr
+        collectStaticPtrSatArgs
     ) where
 
 #include "HsVersions.h"
 
 import CoreSyn
+import PrelNames ( staticPtrDataConName )
 import PprCore
 import CoreFVs( exprFreeVars )
 import Var
@@ -2203,3 +2207,25 @@ isEmptyTy ty
     = True
     | otherwise
     = False
+
+{-
+*****************************************************
+*
+* StaticPtr
+*
+*****************************************************
+-}
+
+-- | @collectStaticPtrSatArgs e@ yields @Just (s, args)@ when @e = s args@
+-- and @s = StaticPtr@ and the application of @StaticPtr@ is saturated.
+--
+-- Yields @Nothing@ otherwise.
+collectStaticPtrSatArgs :: Expr b -> Maybe (Expr b, [Arg b])
+collectStaticPtrSatArgs e
+    | (fun@(Var b), args, _) <- collectArgsTicks (const True) e
+    , Just con <- isDataConId_maybe b
+    , dataConName con == staticPtrDataConName
+    , length args == 5
+    = Just (fun, args)
+collectStaticPtrSatArgs _
+    = Nothing