[GHC] #13614: Rewrite rules not applied exhaustively when simplifying from plugin

[GHC]

#13614: Rewrite rules not applied exhaustively when simplifying from plugin
-------------------------------------+-------------------------------------
        Reporter:  nomeata           |                Owner:  (none)
            Type:  bug               |               Status:  new
        Priority:  normal            |            Milestone:
       Component:  GHC API           |              Version:  8.1
      Resolution:                    |             Keywords:
Operating System:  Unknown/Multiple  |         Architecture:
                                     |  Unknown/Multiple
 Type of failure:  None/Unknown      |            Test Case:
      Blocked By:                    |             Blocking:
 Related Tickets:                    |  Differential Rev(s):
       Wiki Page:                    |
-------------------------------------+-------------------------------------
Changes (by nomeata):

 * status:  closed => new
 * resolution:  worksforme =>


Comment:

 Ok, so this works fine for locally defined things. But I run into the same
 (or a similar) problem where rules attached to globally defined things do
 not fire.

 Here is my test file (with commented-out rule):
 {{{
 {-# OPTIONS_GHC -O -fplugin TestPlugin #-}
 module Test where
 import GHC.Base (foldr)
 {- # RULES "foldr/id_mine" GHC.Base.foldr (:) [] = id #-}
 test :: [a] -> [a]
 test xs = map id xs
 }}}
 and here the plugin, with the fix from earlier:
 {{{
 module TestPlugin where

 import System.Exit
 import Control.Monad

 import GhcPlugins
 import Simplify
 import CoreStats
 import SimplMonad
 import FamInstEnv
 import SimplEnv
 import OccurAnal

 -- Plugin boiler plate

 plugin :: Plugin
 plugin = defaultPlugin { installCoreToDos = install }

 install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
 install _ (simpl:xs) = return $ simpl : pass : xs
   where pass = CoreDoPluginPass "Test" testPass

 -- The plugin

 testPass :: ModGuts -> CoreM ModGuts
 testPass guts = do
     let [expr] = [ e | NonRec v e <- mg_binds guts
                      , occNameString (occName v) == "test" ]
     simplified_expression <- simplify guts expr

     putMsg $
         text "Test" $$
         nest 4 (hang (text "Before" <> colon) 4 (ppr expr)) $$
         nest 4 (hang (text "After" <> colon) 4 (ppr
 simplified_expression))

     liftIO $ exitFailure

 -- A simplifier

 simplify :: ModGuts -> CoreExpr -> CoreM CoreExpr
 simplify guts expr = do
     dflags <- getDynFlags

     let dflags' = dflags { ufVeryAggressive = True }

     us <- liftIO $ mkSplitUniqSupply 's'
     let sz = exprSize expr

     rule_base <- getRuleBase
     vis_orphs <- getVisibleOrphanMods
     let rule_base2 = extendRuleBaseList rule_base (mg_rules guts)
     let rule_env = RuleEnv rule_base2 vis_orphs
     let top_lvls = bindersOfBinds (mg_binds guts)


     (expr', _) <- liftIO $ initSmpl dflags' rule_env emptyFamInstEnvs us
 sz $ do
         simplExpr (simplEnv top_lvls 1) (occurAnalyseExpr expr)
     return expr'



 simplEnv :: [Var] -> Int -> SimplEnv
 simplEnv vars p = env1
   where
     env1 = addNewInScopeIds env0 vars
     env0 =  mkSimplEnv $ SimplMode { sm_names = ["Test"]
                                    , sm_phase = Phase p
                                    , sm_rules = True
                                    , sm_inline = True
                                    , sm_eta_expand = True
                                    , sm_case_case = True }
 }}}

 If I run this I get:
 {{{
 $ ghc-head -O  -dynamic-too -package ghc Test.hs -fforce-recomp
 [1 of 2] Compiling TestPlugin       ( TestPlugin.hs, TestPlugin.o )
 [2 of 2] Compiling Test             ( Test.hs, Test.o )
 Test
     Before:
         \ (@ a) (xs :: [a]) ->
           GHC.Base.build
             @ a
             (\ (@ b1)
                (c [OS=OneShot] :: a -> b1 -> b1)
                (n [OS=OneShot] :: b1) ->
                GHC.Base.foldr @ a @ b1 c n xs)
     After:
         \ (@ a) (xs :: [a]) ->
           GHC.Base.foldr @ a @ [a] (GHC.Types.: @ a) (GHC.Types.[] @ a) xs
 }}}

 Note that `GHC.Base.foldr` is still there in the `After:`: expression,
 despite the `foldr/id` rule in `GHC.Base`, which should simplify this
 code!

 If I add that rule to my module (as hinted at above), it does fire:
 {{{
 $ ghc-head -O  -dynamic-too -package ghc Test.hs -fforce-recomp
 [1 of 2] Compiling TestPlugin       ( TestPlugin.hs, TestPlugin.o )
 [2 of 2] Compiling Test             ( Test.hs, Test.o )
 Test
     Before:
         \ (@ a) (xs :: [a]) ->
           GHC.Base.build
             @ a
             (\ (@ b1)
                (c [OS=OneShot] :: a -> b1 -> b1)
                (n [OS=OneShot] :: b1) ->
                GHC.Base.foldr @ a @ b1 c n xs)
     After: \ (@ a) (xs :: [a]) -> xs
 }}}

--
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/13614#comment:5>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler