Tell built-in rules the Id that the rule has matched

This will let us get at the types of the Id, which in particular means
that for a rule for
    intToInteger :: Int# -> Integer
we can get the "Integer" type, which we can use to build an Integer
literal.

1 files changed, 36 insertions, 27 deletions

diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index 7e798be426..58eefd9e88 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -344,9 +344,9 @@ litEq op_name is_eq
                    ru_fn = op_name,
                    ru_nargs = 2, ru_try = rule_fn }]
   where
-    rule_fn _ [Lit lit, expr] = do_lit_eq lit expr
-    rule_fn _ [expr, Lit lit] = do_lit_eq lit expr
-    rule_fn _ _               = Nothing
+    rule_fn _ _ [Lit lit, expr] = do_lit_eq lit expr
+    rule_fn _ _ [expr, Lit lit] = do_lit_eq lit expr
+    rule_fn _ _ _               = Nothing
 
     do_lit_eq lit expr
       | litIsLifted lit 
@@ -374,8 +374,8 @@ boundsCmp op_name op = [ rule ]
       , ru_nargs = 2
       , ru_try = rule_fn
       }
-    rule_fn _ [a, b] = mkRuleFn op a b
-    rule_fn _ _      = Nothing
+    rule_fn _ _ [a, b] = mkRuleFn op a b
+    rule_fn _ _ _      = Nothing
 
 data Comparison = Gt | Ge | Lt | Le
 
@@ -436,7 +436,7 @@ mkBasicRule :: Name -> Int
 mkBasicRule op_name n_args rule_fn
   = [BuiltinRule { ru_name = occNameFS (nameOccName op_name),
                    ru_fn = op_name,
-                   ru_nargs = n_args, ru_try = rule_fn }]
+                   ru_nargs = n_args, ru_try = \_ -> rule_fn }]
 
 oneLit :: Name -> (Literal -> Maybe CoreExpr)
        -> [CoreRule]
@@ -613,11 +613,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]
@@ -752,39 +752,43 @@ match_inline _ _ = Nothing
 
 match_Integer_convert :: Num a
                       => (a -> Expr CoreBndr)
+                      -> 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)
+                   -> 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)
+                    -> 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))
+                         -> 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 i) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   , y /= 0
@@ -797,61 +801,66 @@ match_Integer_divop_both divop id_unf [xl,yl]
                                Lit (LitInteger r i),
                                Lit (LitInteger s i)]
       _ -> panic "match_Integer_divop_both: mkIntegerId has the wrong type"
-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)
+                        -> 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)
+                        -> 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)
+                         -> 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)
+                             -> 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)
+                              -> 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
 \end{code}