diff options
| -rw-r--r-- | compiler/basicTypes/MkId.lhs | 10 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreSyn.lhs | 2 | ||||
| -rw-r--r-- | compiler/prelude/PrelRules.lhs | 63 | ||||
| -rw-r--r-- | compiler/specialise/Rules.lhs | 12 |
4 files changed, 48 insertions, 39 deletions
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 4671b394cc..a7f4b70d61 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -503,13 +503,13 @@ mkDictSelId no_unf name clas -- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g } dictSelRule :: Int -> Arity - -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr + -> 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) @@ -920,12 +920,12 @@ seqId = pcMiscPrelId seqName ty info , ru_try = match_seq_of_cast } -match_seq_of_cast :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr +match_seq_of_cast :: 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 bfe6dec72e..40243edc0a 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -539,7 +539,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 :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr + ru_try :: 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 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} diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index 2a4a560659..42c1eda081 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -369,7 +369,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 is_active id_unf in_scope args rough_args r) of + go ms (r:rs) = case (matchRule 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) @@ -446,7 +446,7 @@ to lookupRule are the result of a lazy substitution \begin{code} ------------------------------------ -matchRule :: (Activation -> Bool) -> IdUnfoldingFun +matchRule :: Id -> (Activation -> Bool) -> IdUnfoldingFun -> InScopeSet -> [CoreExpr] -> [Maybe Name] -> CoreRule -> Maybe CoreExpr @@ -473,14 +473,14 @@ matchRule :: (Activation -> Bool) -> IdUnfoldingFun -- Any 'surplus' arguments in the input are simply put on the end -- of the output. -matchRule _is_active id_unf _in_scope args _rough_args +matchRule 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 id_unf args of + = case match_fn 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 }) @@ -1089,7 +1089,7 @@ ruleAppCheck_help env fn args rules = ptext (sLit "Rule") <+> doubleQuotes (ftext name) rule_info rule - | Just _ <- matchRule noBlackList (rc_id_unf env) emptyInScopeSet args rough_args rule + | Just _ <- matchRule fn noBlackList (rc_id_unf env) emptyInScopeSet args rough_args rule = text "matches (which is very peculiar!)" rule_info (BuiltinRule {}) = text "does not match" |