Commit 79ee264a authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files

Pass DynFlags to the ru_try functions of built-in rules

parent b0f4c44e
......@@ -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]
......
......@@ -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
......
......@@ -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}
......@@ -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) ->
......
......@@ -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"
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment