Stop the simplifier from removing StaticPtr binds.
authorFacundo Domínguez <facundo.dominguez@tweag.io>
Tue, 28 Jun 2016 01:30:50 +0000 (22:30 -0300)
committerFacundo Domínguez <facundo.dominguez@tweag.io>
Tue, 28 Jun 2016 14:07:59 +0000 (11:07 -0300)
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

compiler/coreSyn/CoreLint.hs
compiler/coreSyn/CoreUtils.hs
compiler/main/TidyPgm.hs
compiler/simplCore/SetLevels.hs
compiler/simplCore/SimplCore.hs
testsuite/tests/codeGen/should_run/all.T
testsuite/tests/rts/all.T

index e7acafc..73e93ea 100644 (file)
@@ -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) $
index aeb0afb..f11c6be 100644 (file)
@@ -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
index d7b45ce..aed985d 100644 (file)
@@ -20,11 +20,10 @@ import CoreFVs
 import CoreTidy
 import CoreMonad
 import CorePrep
-import CoreUtils        (rhsIsStatic)
+import CoreUtils        (rhsIsStatic, collectStaticPtrSatArgs)
 import CoreStats        (coreBindsStats, CoreStats(..))
 import CoreLint
 import Literal
-import PrelNames
 import Rules
 import PatSyn
 import ConLike
@@ -655,11 +654,8 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
                       || isStaticPtrApp e
 
   isStaticPtrApp :: CoreExpr -> Bool
-  isStaticPtrApp (collectTyBinders -> (_, e))
-      | (Var v, _) <- collectArgs e
-      , Just con <- isDataConId_maybe v
-      =  dataConName con == staticPtrDataConName
-  isStaticPtrApp _ = False
+  isStaticPtrApp (collectTyBinders -> (_, e)) =
+    isJust $ collectStaticPtrSatArgs e
 
   rule_rhs_vars  = mapUnionVarSet ruleRhsFreeVars imp_id_rules
   vect_var_vs    = mkVarSet [var_v | (var, var_v) <- nameEnvElts vect_vars, isGlobalId var]
index e9a0004..fc55564 100644 (file)
@@ -64,7 +64,11 @@ module SetLevels (
 
 import CoreSyn
 import CoreMonad        ( FloatOutSwitches(..) )
-import CoreUtils        ( exprType, exprOkForSpeculation, exprIsBottom )
+import CoreUtils        ( exprType
+                        , exprOkForSpeculation
+                        , exprIsBottom
+                        , collectStaticPtrSatArgs
+                        )
 import CoreArity        ( exprBotStrictness_maybe )
 import CoreFVs          -- all of it
 import CoreSubst
@@ -86,6 +90,7 @@ import Outputable
 import FastString
 import UniqDFM
 import FV
+import Data.Maybe
 
 {-
 ************************************************************************
@@ -1099,7 +1104,8 @@ newLvlVar :: LevelledExpr        -- The RHS of the new binding
           -> LvlM Id
 newLvlVar lvld_rhs is_bot
   = do { uniq <- getUniqueM
-       ; return (add_bot_info (mkLocalIdOrCoVar (mk_name uniq) rhs_ty)) }
+       ; return (add_bot_info (mk_id uniq))
+       }
   where
     add_bot_info var  -- We could call annotateBotStr always, but the is_bot
                       -- flag just tells us when we don't need to do so
@@ -1107,7 +1113,13 @@ newLvlVar lvld_rhs is_bot
        | otherwise = var
     de_tagged_rhs = deTagExpr lvld_rhs
     rhs_ty = exprType de_tagged_rhs
-    mk_name uniq = mkSystemVarName uniq (mkFastString "lvl")
+    mk_id uniq
+      -- See Note [Grand plan for static forms] in SimplCore.
+      | isJust (collectStaticPtrSatArgs lvld_rhs)
+      = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))
+                            rhs_ty
+      | otherwise
+      = mkLocalIdOrCoVar (mkSystemVarName uniq (mkFastString "lvl")) rhs_ty
 
 cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])
 cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
index 85ae8cd..29035c8 100644 (file)
@@ -1029,8 +1029,22 @@ Here is a running example:
   executed, even when optimizations are disabled.  So we get
 
    k = map toUpper
-   lvl = StaticPtr <fingerprint> k
-   f x = ...lvl...
+   static_ptr = StaticPtr <fingerprint> k
+   f x = ...static_ptr...
+
+  The FloatOut pass is careful to produce an /exported/ Id for a floated
+  'StaticPtr', so the binding is not removed by the simplifier (see #12207).
+  E.g. the code for `f` above might look like
+
+    static_ptr = StaticPtr <fingerprint> k
+    f x = ...(staticKey static_ptr)...
+
+  which might correctly be simplified to
+
+    f x = ...<fingerprint>...
+
+  BUT the top-level binding for static_ptr must remain, so that it can be
+  collected to populate the Static Pointer Table.
 
 * The CoreTidy pass produces a C function which inserts all the
   floated 'StaticPtr' in the static pointer table (see the call to
index b6249ed..42ec7d3 100644 (file)
@@ -117,9 +117,7 @@ test('T8103', only_ways(['normal']), compile_and_run, [''])
 test('T7953', reqlib('random'), compile_and_run, [''])
 test('T8256', normal, compile_and_run, ['-dcore-lint -O1'])
 test('T6084',normal, compile_and_run, ['-O2'])
-test('CgStaticPointers',
-     [when(doing_ghci(), extra_hc_opts('-fobject-code')),
-      expect_broken_for(12207, opt_ways)],
+test('CgStaticPointers', [when(doing_ghci(), extra_hc_opts('-fobject-code'))],
      compile_and_run, [''])
 test('StaticArraySize', [when(doing_ghci(), extra_hc_opts('-fobject-code'))],
      compile_and_run, ['-O2'])
index 086f479..25ea8b5 100644 (file)
@@ -275,13 +275,9 @@ test('rdynamic', [ unless(opsys('linux') or opsys('mingw32'), skip)
                  ],
      compile_and_run, ['-rdynamic -package ghc'])
 
-test('GcStaticPointers',
-     [when(doing_ghci(), extra_hc_opts('-fobject-code')),
-      expect_broken_for(12207, opt_ways)],
+test('GcStaticPointers', [when(doing_ghci(), extra_hc_opts('-fobject-code'))],
      compile_and_run, [''])
-test('ListStaticPointers',
-     [when(doing_ghci(), extra_hc_opts('-fobject-code')),
-      expect_broken_for(12207, opt_ways)],
+test('ListStaticPointers', [when(doing_ghci(), extra_hc_opts('-fobject-code'))],
      compile_and_run, [''])
 
 # 251 = RTS exit code for "out of memory"