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

25 Apr 2017

      #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
           Keywords:                 |  Operating System:  Unknown/Multiple
       Architecture:                 |   Type of failure:  None/Unknown
  Unknown/Multiple                   |
          Test Case:                 |        Blocked By:
           Blocking:                 |   Related Tickets:
Differential Rev(s):                 |         Wiki Page:
-------------------------------------+-------------------------------------
 Consider this program:
 {{{
 {-# OPTIONS_GHC -O -fplugin TestPlugin #-}
 module Test where

 foo :: Int -> Int
 foo = id
 {-# INLINE [0] foo #-}

 {-# RULES
 "foo1" [1] foo 1 = foo 2
 "foo2" [1] foo 2 = foo 3
  #-}

 fun :: Int -> Int -> Int
 fun = (+)
 {-# NOINLINE fun #-}

 test = foo 1 `fun` foo 2
 }}}

 I would expect that one run of the simplifier in phase `1` will turn this
 into
 {{{
 test = foo 3 `fun` foo 3
 }}}

 I am using this plugin to test this:
 {{{
 module TestPlugin where

 import System.Exit
 import Control.Monad

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

 -- 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

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

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

 But I get:

 {{{
 $ ghc-head -package ghc Test.hs
 [1 of 2] Compiling TestPlugin       ( TestPlugin.hs, TestPlugin.o )
 [2 of 2] Compiling Test             ( Test.hs, Test.o )
 Test
     Before: fun (foo (GHC.Types.I# 1#)) (foo (GHC.Types.I# 2#))
     After: fun (foo (GHC.Types.I# 2#)) (foo (GHC.Types.I# 3#))
 }}}

 If I however compile this without the plugin, and look at what’s happening
 with `-dverbose-core2core`, I observe this:

 {{{
 …
 test :: Int
 test = fun (foo (GHC.Types.I# 1#)) (foo (GHC.Types.I# 2#))
 …
 ==================== Simplifier ====================
   Max iterations = 4
   SimplMode {Phase = 1 [main],
              inline,
              rules,
              eta-expand,
              case-of-case}
 …
 test :: Int
 test = fun (foo (GHC.Types.I# 3#)) (foo (GHC.Types.I# 3#))
 …
 }}}

 So what am I doing wrong in my plugin? Any help is appreciated.

--
Ticket URL: http://ghc.haskell.org/trac/ghc/ticket/13614
GHC http://www.haskell.org/ghc/
The Glasgow Haskell Compiler