Pass DynFlags to the ru_try functions of built-in rules

6 files changed, 90 insertions, 66 deletions

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 7bb5d160b9..1805ccd25e 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -505,14 +505,14 @@ mkDictSelId no_unf name clas
 				-- varToCoreExpr needed for equality superclass selectors
 				--   sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }
 
-dictSelRule :: Int -> Arity 
-            -> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
+dictSelRule :: Int -> Arity
+            -> DynFlags -> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
 -- Tries to persuade the argument to look like a constructor
 -- application, using exprIsConApp_maybe, and then selects
 -- from it
 --       sel_i t1..tk (D t1..tk op1 ... opm) = opi
 --
-dictSelRule val_index n_ty_args _ id_unf args
+dictSelRule val_index n_ty_args _ _ id_unf args
   | (dict_arg : _) <- drop n_ty_args args
   , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
   = Just (con_args !! val_index)
@@ -935,12 +935,13 @@ seqId = pcMiscPrelId seqName ty info
                                 , ru_try   = match_seq_of_cast
                                 }
 
-match_seq_of_cast :: Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
+match_seq_of_cast :: DynFlags -> Id -> IdUnfoldingFun -> [CoreExpr]
+                  -> Maybe CoreExpr
     -- See Note [Built-in RULES for seq]
-match_seq_of_cast _ _ [Type _, Type res_ty, Cast scrut co, expr]
+match_seq_of_cast _ _ _ [Type _, Type res_ty, Cast scrut co, expr]
   = Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty,
                               scrut, expr])
-match_seq_of_cast _ _ _ = Nothing
+match_seq_of_cast _ _ _ _ = Nothing
 
 ------------------------------------------------
 lazyId :: Id	-- See Note [lazyId magic]
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index f972fc706d..e9a044e951 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -101,6 +101,7 @@ import DataCon
 import Module
 import TyCon
 import BasicTypes
+import DynFlags
 import FastString
 import Outputable
 import Util
@@ -561,7 +562,7 @@ data CoreRule
 	ru_fn    :: Name,       -- ^ As above
 	ru_nargs :: Int,	-- ^ Number of arguments that 'ru_try' consumes,
 				-- if it fires, including type arguments
-	ru_try  :: Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
+	ru_try  :: DynFlags -> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
 		-- ^ This function does the rewrite.  It given too many
 		-- arguments, it simply discards them; the returned 'CoreExpr'
 		-- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args
diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index b5b350b9d9..2e09e03446 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -45,6 +45,7 @@ import FastString
 import StaticFlags ( opt_SimplExcessPrecision )
 import Constants
 import BasicTypes
+import DynFlags
 import Util
 
 import Control.Monad
@@ -439,7 +440,7 @@ mkBasicRule op_name n_args rm
   = BuiltinRule { ru_name = occNameFS (nameOccName op_name),
                   ru_fn = op_name,
                   ru_nargs = n_args,
-                  ru_try = \_ -> runRuleM rm }
+                  ru_try = \_ _ -> runRuleM rm }
 
 newtype RuleM r = RuleM
   { runRuleM :: IdUnfoldingFun -> [CoreExpr] -> Maybe r }
@@ -716,11 +717,11 @@ builtinRules :: [CoreRule]
 builtinRules
   = [BuiltinRule { ru_name = fsLit "AppendLitString",
                    ru_fn = unpackCStringFoldrName,
-                   ru_nargs = 4, ru_try = \_ -> match_append_lit },
+                   ru_nargs = 4, ru_try = \_ _ -> match_append_lit },
      BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
-                   ru_nargs = 2, ru_try = \_ -> match_eq_string },
+                   ru_nargs = 2, ru_try = \_ _ -> match_eq_string },
      BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
-                   ru_nargs = 2, ru_try = \_ -> match_inline }]
+                   ru_nargs = 2, ru_try = \_ _ -> match_inline }]
  ++ builtinIntegerRules
 
 builtinIntegerRules :: [CoreRule]
@@ -889,98 +890,106 @@ match_inline _ _ = Nothing
 --   wordToInteger (79::Word#) = 79::Integer   
 -- Similarly Int64, Word64
 
-match_IntToInteger :: Id
+match_IntToInteger :: DynFlags
+                   -> Id
                    -> IdUnfoldingFun
                    -> [Expr CoreBndr]
                    -> Maybe (Expr CoreBndr)
-match_IntToInteger id id_unf [xl]
+match_IntToInteger _ id id_unf [xl]
   | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl
   = case idType id of
     FunTy _ integerTy ->
         Just (Lit (LitInteger x integerTy))
     _ ->
         panic "match_IntToInteger: Id has the wrong type"
-match_IntToInteger _ _ _ = Nothing
+match_IntToInteger _ _ _ _ = Nothing
 
-match_WordToInteger :: Id
+match_WordToInteger :: DynFlags
+                    -> Id
                     -> IdUnfoldingFun
                     -> [Expr CoreBndr]
                     -> Maybe (Expr CoreBndr)
-match_WordToInteger id id_unf [xl]
+match_WordToInteger _ id id_unf [xl]
   | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl
   = case idType id of
     FunTy _ integerTy ->
         Just (Lit (LitInteger x integerTy))
     _ ->
         panic "match_WordToInteger: Id has the wrong type"
-match_WordToInteger _ _ _ = Nothing
+match_WordToInteger _ _ _ _ = Nothing
 
-match_Int64ToInteger :: Id
+match_Int64ToInteger :: DynFlags
+                     -> Id
                      -> IdUnfoldingFun
                      -> [Expr CoreBndr]
                      -> Maybe (Expr CoreBndr)
-match_Int64ToInteger id id_unf [xl]
+match_Int64ToInteger _ id id_unf [xl]
   | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl
   = case idType id of
     FunTy _ integerTy ->
         Just (Lit (LitInteger x integerTy))
     _ ->
         panic "match_Int64ToInteger: Id has the wrong type"
-match_Int64ToInteger _ _ _ = Nothing
+match_Int64ToInteger _ _ _ _ = Nothing
 
-match_Word64ToInteger :: Id
+match_Word64ToInteger :: DynFlags
+                      -> Id
                       -> IdUnfoldingFun
                       -> [Expr CoreBndr]
                       -> Maybe (Expr CoreBndr)
-match_Word64ToInteger id id_unf [xl]
+match_Word64ToInteger _ id id_unf [xl]
   | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl
   = case idType id of
     FunTy _ integerTy ->
         Just (Lit (LitInteger x integerTy))
     _ ->
         panic "match_Word64ToInteger: Id has the wrong type"
-match_Word64ToInteger _ _ _ = Nothing
+match_Word64ToInteger _ _ _ _ = Nothing
 
 -------------------------------------------------
 match_Integer_convert :: Num a
                       => (a -> Expr CoreBndr)
+                      -> DynFlags
                       -> Id
                       -> IdUnfoldingFun
                       -> [Expr CoreBndr]
                       -> Maybe (Expr CoreBndr)
-match_Integer_convert convert _ id_unf [xl]
+match_Integer_convert convert _ _ id_unf [xl]
   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
   = Just (convert (fromInteger x))
-match_Integer_convert _ _ _ _ = Nothing
+match_Integer_convert _ _ _ _ _ = Nothing
 
 match_Integer_unop :: (Integer -> Integer)
+                   -> DynFlags
                    -> Id
                    -> IdUnfoldingFun
                    -> [Expr CoreBndr]
                    -> Maybe (Expr CoreBndr)
-match_Integer_unop unop _ id_unf [xl]
+match_Integer_unop unop _ _ id_unf [xl]
   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
   = Just (Lit (LitInteger (unop x) i))
-match_Integer_unop _ _ _ _ = Nothing
+match_Integer_unop _ _ _ _ _ = Nothing
 
 match_Integer_binop :: (Integer -> Integer -> Integer)
+                    -> DynFlags
                     -> Id
                     -> IdUnfoldingFun
                     -> [Expr CoreBndr]
                     -> Maybe (Expr CoreBndr)
-match_Integer_binop binop _ id_unf [xl,yl]
+match_Integer_binop binop _ _ id_unf [xl,yl]
   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   = Just (Lit (LitInteger (x `binop` y) i))
-match_Integer_binop _ _ _ _ = Nothing
+match_Integer_binop _ _ _ _ _ = Nothing
 
 -- This helper is used for the quotRem and divMod functions
 match_Integer_divop_both :: (Integer -> Integer -> (Integer, Integer))
+                         -> DynFlags
                          -> Id
                          -> IdUnfoldingFun
                          -> [Expr CoreBndr]
                          -> Maybe (Expr CoreBndr)
-match_Integer_divop_both divop _ id_unf [xl,yl]
+match_Integer_divop_both divop _ _ id_unf [xl,yl]
   | Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   , y /= 0
@@ -990,74 +999,80 @@ match_Integer_divop_both divop _ id_unf [xl,yl]
                      Type t,
                      Lit (LitInteger r t),
                      Lit (LitInteger s t)]
-match_Integer_divop_both _ _ _ _ = Nothing
+match_Integer_divop_both _ _ _ _ _ = Nothing
 
 -- This helper is used for the quotRem and divMod functions
 match_Integer_divop_one :: (Integer -> Integer -> Integer)
+                        -> DynFlags
                         -> Id
                         -> IdUnfoldingFun
                         -> [Expr CoreBndr]
                         -> Maybe (Expr CoreBndr)
-match_Integer_divop_one divop _ id_unf [xl,yl]
+match_Integer_divop_one divop _ _ id_unf [xl,yl]
   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   , y /= 0
   = Just (Lit (LitInteger (x `divop` y) i))
-match_Integer_divop_one _ _ _ _ = Nothing
+match_Integer_divop_one _ _ _ _ _ = Nothing
 
 match_Integer_Int_binop :: (Integer -> Int -> Integer)
+                        -> DynFlags
                         -> Id
                         -> IdUnfoldingFun
                         -> [Expr CoreBndr]
                         -> Maybe (Expr CoreBndr)
-match_Integer_Int_binop binop _ id_unf [xl,yl]
+match_Integer_Int_binop binop _ _ id_unf [xl,yl]
   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
   , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
   = Just (Lit (LitInteger (x `binop` fromIntegral y) i))
-match_Integer_Int_binop _ _ _ _ = Nothing
+match_Integer_Int_binop _ _ _ _ _ = Nothing
 
 match_Integer_binop_Bool :: (Integer -> Integer -> Bool)
+                         -> DynFlags
                          -> Id
                          -> IdUnfoldingFun
                          -> [Expr CoreBndr]
                          -> Maybe (Expr CoreBndr)
-match_Integer_binop_Bool binop _ id_unf [xl, yl]
+match_Integer_binop_Bool binop _ _ id_unf [xl, yl]
   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   = Just (if x `binop` y then trueVal else falseVal)
-match_Integer_binop_Bool _ _ _ _ = Nothing
+match_Integer_binop_Bool _ _ _ _ _ = Nothing
 
 match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering)
+                             -> DynFlags
                              -> Id
                              -> IdUnfoldingFun
                              -> [Expr CoreBndr]
                              -> Maybe (Expr CoreBndr)
-match_Integer_binop_Ordering binop _ id_unf [xl, yl]
+match_Integer_binop_Ordering binop _ _ id_unf [xl, yl]
   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   = Just $ case x `binop` y of
              LT -> ltVal
              EQ -> eqVal
              GT -> gtVal
-match_Integer_binop_Ordering _ _ _ _ = Nothing
+match_Integer_binop_Ordering _ _ _ _ _ = Nothing
 
 match_Integer_Int_encodeFloat :: RealFloat a
                               => (a -> Expr CoreBndr)
+                              -> DynFlags
                               -> Id
                               -> IdUnfoldingFun
                               -> [Expr CoreBndr]
                               -> Maybe (Expr CoreBndr)
-match_Integer_Int_encodeFloat mkLit _ id_unf [xl,yl]
+match_Integer_Int_encodeFloat mkLit _ _ id_unf [xl,yl]
   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
   , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
   = Just (mkLit $ encodeFloat x (fromInteger y))
-match_Integer_Int_encodeFloat _ _ _ _ = Nothing
+match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing
 
-match_decodeDouble :: Id
+match_decodeDouble :: DynFlags
+                   -> Id
                    -> IdUnfoldingFun
                    -> [Expr CoreBndr]
                    -> Maybe (Expr CoreBndr)
-match_decodeDouble fn id_unf [xl]
+match_decodeDouble _ fn id_unf [xl]
   | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl
   = case idType fn of
     FunTy _ (TyConApp _ [integerTy, intHashTy]) ->
@@ -1070,25 +1085,27 @@ match_decodeDouble fn id_unf [xl]
                              Lit (MachInt (toInteger z))]
     _ ->
         panic "match_decodeDouble: Id has the wrong type"
-match_decodeDouble _ _ _ = Nothing
+match_decodeDouble _ _ _ _ = Nothing
 
 match_XToIntegerToX :: Name
+                    -> DynFlags
                     -> Id
                     -> IdUnfoldingFun
                     -> [Expr CoreBndr]
                     -> Maybe (Expr CoreBndr)
-match_XToIntegerToX n _ _ [App (Var x) y]
+match_XToIntegerToX n _ _ _ [App (Var x) y]
   | idName x == n
   = Just y
-match_XToIntegerToX _ _ _ _ = Nothing
+match_XToIntegerToX _ _ _ _ _ = Nothing
 
 match_smallIntegerTo :: PrimOp
+                     -> DynFlags
                      -> Id
                      -> IdUnfoldingFun
                      -> [Expr CoreBndr]
                      -> Maybe (Expr CoreBndr)
-match_smallIntegerTo primOp _ _ [App (Var x) y]
+match_smallIntegerTo primOp _ _ _ [App (Var x) y]
   | idName x == smallIntegerName
   = Just $ App (Var (mkPrimOpId primOp)) y
-match_smallIntegerTo _ _ _ _ = Nothing
+match_smallIntegerTo _ _ _ _ _ = Nothing
 \end{code}
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index bc991b3bf1..68c82f5718 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1553,7 +1553,8 @@ tryRules env rules fn args call_cont
   | null rules
   = return Nothing
   | otherwise
-  = do { case lookupRule (activeRule env) (getUnfoldingInRuleMatch env)
+  = do { dflags <- getDynFlags
+       ; case lookupRule dflags (activeRule env) (getUnfoldingInRuleMatch env)
                          (getInScope env) fn args rules of {
            Nothing               -> return Nothing ;   -- No rule matches
            Just (rule, rule_rhs) ->
diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 231fd27ac6..9c473e5a3a 100644
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -47,6 +47,7 @@ import Name             ( Name, NamedThing(..) )
 import NameEnv
 import Unify            ( ruleMatchTyX, MatchEnv(..) )
 import BasicTypes       ( Activation, CompilerPhase, isActive )
+import DynFlags         ( DynFlags )
 import StaticFlags      ( opt_PprStyle_Debug )
 import Outputable
 import FastString
@@ -350,7 +351,8 @@ pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs)
 -- supplied rules to this instance of an application in a given
 -- context, returning the rule applied and the resulting expression if
 -- successful.
-lookupRule :: (Activation -> Bool)      -- When rule is active
+lookupRule :: DynFlags
+            -> (Activation -> Bool)      -- When rule is active
             -> IdUnfoldingFun           -- When Id can be unfolded
             -> InScopeSet
             -> Id -> [CoreExpr]
@@ -358,7 +360,7 @@ lookupRule :: (Activation -> Bool)      -- When rule is active
 
 -- See Note [Extra args in rule matching]
 -- See comments on matchRule
-lookupRule is_active id_unf in_scope fn args rules
+lookupRule dflags is_active id_unf in_scope fn args rules
   = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $
     case go [] rules of
         []     -> Nothing
@@ -368,7 +370,7 @@ lookupRule is_active id_unf in_scope fn args rules
 
     go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]
     go ms []           = ms
-    go ms (r:rs) = case (matchRule fn is_active id_unf in_scope args rough_args r) of
+    go ms (r:rs) = case (matchRule dflags fn is_active id_unf in_scope args rough_args r) of
                         Just e  -> go ((r,e):ms) rs
                         Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$
                                    --   ppr [ (arg_id, unfoldingTemplate unf)
@@ -445,7 +447,7 @@ to lookupRule are the result of a lazy substitution
 
 \begin{code}
 ------------------------------------
-matchRule :: Id -> (Activation -> Bool) -> IdUnfoldingFun
+matchRule :: DynFlags -> Id -> (Activation -> Bool) -> IdUnfoldingFun
           -> InScopeSet
           -> [CoreExpr] -> [Maybe Name]
           -> CoreRule -> Maybe CoreExpr
@@ -472,14 +474,14 @@ matchRule :: Id -> (Activation -> Bool) -> IdUnfoldingFun
 -- Any 'surplus' arguments in the input are simply put on the end
 -- of the output.
 
-matchRule fn _is_active id_unf _in_scope args _rough_args
+matchRule dflags fn _is_active id_unf _in_scope args _rough_args
           (BuiltinRule { ru_try = match_fn })
 -- Built-in rules can't be switched off, it seems
-  = case match_fn fn id_unf args of
+  = case match_fn dflags fn id_unf args of
         Just expr -> Just expr
         Nothing   -> Nothing
 
-matchRule _ is_active id_unf in_scope args rough_args
+matchRule _ _ is_active id_unf in_scope args rough_args
           (Rule { ru_act = act, ru_rough = tpl_tops,
                   ru_bndrs = tpl_vars, ru_args = tpl_args,
                   ru_rhs = rhs })
@@ -1085,21 +1087,22 @@ ruleAppCheck_help env fn args rules
     i_args = args `zip` [1::Int ..]
     rough_args = map roughTopName args
 
-    check_rule rule = rule_herald rule <> colon <+> rule_info rule
+    check_rule rule = sdocWithDynFlags $ \dflags ->
+                      rule_herald rule <> colon <+> rule_info dflags rule
 
     rule_herald (BuiltinRule { ru_name = name })
         = ptext (sLit "Builtin rule") <+> doubleQuotes (ftext name)
     rule_herald (Rule { ru_name = name })
         = ptext (sLit "Rule") <+> doubleQuotes (ftext name)
 
-    rule_info rule
-        | Just _ <- matchRule fn noBlackList (rc_id_unf env) emptyInScopeSet args rough_args rule
+    rule_info dflags rule
+        | Just _ <- matchRule dflags fn noBlackList (rc_id_unf env) emptyInScopeSet args rough_args rule
         = text "matches (which is very peculiar!)"
 
-    rule_info (BuiltinRule {}) = text "does not match"
+    rule_info _ (BuiltinRule {}) = text "does not match"
 
-    rule_info (Rule { ru_act = act,
-                      ru_bndrs = rule_bndrs, ru_args = rule_args})
+    rule_info _ (Rule { ru_act = act,
+                        ru_bndrs = rule_bndrs, ru_args = rule_args})
         | not (rc_is_active env act)  = text "active only in later phase"
         | n_args < n_rule_args        = text "too few arguments"
         | n_mismatches == n_rule_args = text "no arguments match"
diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index 4307ff75df..083d1502bb 100644
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -1063,9 +1063,9 @@ specCalls subst rules_for_me calls_for_me fn rhs
     body         = mkLams (drop n_dicts rhs_ids) rhs_body
                 -- Glue back on the non-dict lambdas
 
-    already_covered :: [CoreExpr] -> Bool
-    already_covered args          -- Note [Specialisations already covered]
-       = isJust (lookupRule (const True) realIdUnfolding
+    already_covered :: DynFlags -> [CoreExpr] -> Bool
+    already_covered dflags args      -- Note [Specialisations already covered]
+       = isJust (lookupRule dflags (const True) realIdUnfolding
                             (substInScope subst)
                             fn args rules_for_me)
 
@@ -1119,7 +1119,8 @@ specCalls subst rules_for_me calls_for_me fn rhs
                  ty_args   = mk_ty_args call_ts poly_tyvars
                  inst_args = ty_args ++ map Var inst_dict_ids
 
-           ; if already_covered inst_args then
+           ; dflags <- getDynFlags
+           ; if already_covered dflags inst_args then
                 return Nothing
              else do
            {    -- Figure out the type of the specialised function