[commit: ghc] wip/T12618: ConApp compression: Fix collectStaticPtrSatArgs (c312228)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T12618
Link       : http://ghc.haskell.org/trac/ghc/changeset/c312228f666b4048df68f9cc4017c9a589ae2737/ghc

>---------------------------------------------------------------

commit c312228f666b4048df68f9cc4017c9a589ae2737
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Fri Oct 21 11:37:08 2016 -0400

    ConApp compression: Fix collectStaticPtrSatArgs


>---------------------------------------------------------------

c312228f666b4048df68f9cc4017c9a589ae2737
 compiler/coreSyn/CoreUtils.hs   | 23 ++++++++++++++++++-----
 compiler/deSugar/DsBinds.hs     |  2 +-
 compiler/simplCore/SetLevels.hs |  5 ++---
 3 files changed, 21 insertions(+), 9 deletions(-)

diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index 49d5d08..c2d4eba 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -50,7 +50,7 @@ module CoreUtils (
         stripTicksE, stripTicksT,
 
         -- * StaticPtr
-        collectStaticPtrSatArgs
+        collectStaticPtrSatArgs, isStaticPtrApp
     ) where
 
 #include "HsVersions.h"
@@ -2265,11 +2265,11 @@ isEmptyTy ty
 -- and @s = StaticPtr@ and the application of @StaticPtr@ is saturated.
 --
 -- Yields @Nothing@ otherwise.
-collectStaticPtrSatArgs :: Expr b -> Maybe (Expr b, [Arg b])
-collectStaticPtrSatArgs (ConApp dc cargs)
+collectStaticPtrSatArgs :: CoreExpr -> Maybe (CoreExpr, [CoreArg])
+collectStaticPtrSatArgs e@(ConApp dc _)
     | dataConName dc == staticPtrDataConName
-    -- the StaticPtr con has no compressible arguments
-    , let args = cargs
+    -- the StaticPtr con has one compressible argument, which we ignore here
+    , let args = collectConArgs e
     , length args == 5
     = Just (Var (dataConWorkId dc), args) -- TODO #12618 hack
 collectStaticPtrSatArgs e
@@ -2280,3 +2280,16 @@ collectStaticPtrSatArgs e
     = Just (fun, args)
 collectStaticPtrSatArgs _
     = Nothing
+
+isStaticPtrApp :: Expr b -> Bool
+isStaticPtrApp e@(ConApp dc _)
+    | dataConName dc == staticPtrDataConName
+    = True
+isStaticPtrApp e
+    | (fun@(Var b), args, _) <- collectArgsTicks (const True) e
+    , Just con <- isDataConId_maybe b
+    , dataConName con == staticPtrDataConName
+    , length args == 5
+    = True
+isStaticPtrApp _
+    = False
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 2fcdfda..457bbf7 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -825,7 +825,7 @@ decomposeRuleLhs orig_bndrs orig_lhs
 
    -- We do not represent data con using their workers, but the rule code really likes
    -- having IDs around, so lets return that here. The matcher will know what to do with it.
-   collectArgs' e@(ConApp dc cargs) = (Var (dataConWorkId dc), args)
+   collectArgs' e@(ConApp dc _) = (Var (dataConWorkId dc), args)
      where args = collectConArgs e
    collectArgs' e = collectArgs e
 
diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs
index 0d1ad99..efec696 100644
--- a/compiler/simplCore/SetLevels.hs
+++ b/compiler/simplCore/SetLevels.hs
@@ -67,7 +67,7 @@ import CoreMonad        ( FloatOutSwitches(..) )
 import CoreUtils        ( exprType
                         , exprOkForSpeculation
                         , exprIsBottom
-                        , collectStaticPtrSatArgs
+                        , isStaticPtrApp
                         )
 import CoreArity        ( exprBotStrictness_maybe )
 import CoreFVs          -- all of it
@@ -90,7 +90,6 @@ import Outputable
 import FastString
 import UniqDFM
 import FV
-import Data.Maybe
 
 {-
 ************************************************************************
@@ -1121,7 +1120,7 @@ newLvlVar lvld_rhs is_bot
     rhs_ty = exprType de_tagged_rhs
     mk_id uniq
       -- See Note [Grand plan for static forms] in SimplCore.
-      | isJust (collectStaticPtrSatArgs lvld_rhs)
+      | isStaticPtrApp lvld_rhs
       = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))
                             rhs_ty
       | otherwise