Commit 7a327c12 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Major overhaul of the Simplifier

This big patch completely overhauls the Simplifier.  The simplifier
had grown old and crufty, and was hard to understand and maintain.
This new version is still quite complicated, because the simplifier
does a lot, but it's much easier to understand, for me at least.

It does mean that I have touched almost every line of the simplifier,
so the diff is a large one.

Big changes are these

* When simplifying an Expr we generate a simplified Expr plus a 
  bunch of "floats", which are bindings that have floated out
  of the Expr.  Before, this float stuff was returned separately,
  but not they are embedded in the SimplEnv, which makes the
  plumbing much easier and more robust.  In particular, the
  SimplEnv already meaintains the "in-scope set", and making
  that travel with the floats helps to ensure that we always 
  use the right in-scope set.

  This change has a pervasive effect.

* Rather than simplifying the args of a call before trying rules
  and inlining, we now defer simplifying the args until both
  rules and inlining have failed, so we're going to leave a
  call in the result.  This avoids the risk of repeatedly 
  simplifying an argument, which was handled by funny ad-hoc
  flags before.  
  
  The downside is that we must apply the substitution to the args before
  rule-matching; and if thep rule doesn't match that is wasted work.
  But having any rules at all is the exception not the rule, and the
  substitution is lazy, so we only substitute until a no-match is found.
  The code is much more elegant though.

* A SimplCont is now more zipper-like. It used to have an embedded
  function, but that was a bit hard to think about, and now it's
  nice and consistent. The relevant constructors are StrictArg
  and StrictBind

* Each Rule now has an *arity* (gotten by CoreSyn.ruleArity), which 
  tells how many arguments it matches against.  This entailed adding
  a field ru_nargs to a BuiltinRule.  And that made me look at 
  PrelRules; I did quite a bit of refactoring in the end, so the
  diff in PrelRules looks much biggger than it really is.

* A little refactoring in OccurAnal.  The key change is that in 
  the RHS of	x = y `cast` co
  we regard 'y' as "many", so that it doesn't get inlined into 
  the RHS of x.  This allows x to be inlined elsewhere.  It's 
  very like the existing situation for
		x = Just y
  where we treat 'y' as "many".
parent 326d5e5a
......@@ -42,7 +42,7 @@ module CoreSyn (
-- Core rules
CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
RuleName, seqRules,
RuleName, seqRules, ruleArity,
isBuiltinRule, ruleName, isLocalRule, ruleIdName
) where
......@@ -216,11 +216,16 @@ data CoreRule
ru_name :: RuleName, -- and suchlike. It has no free variables.
ru_fn :: Name, -- Name of the Id at
-- the head of this rule
ru_nargs :: Int, -- Number of args that ru_try expects
ru_try :: [CoreExpr] -> Maybe CoreExpr }
isBuiltinRule (BuiltinRule {}) = True
isBuiltinRule _ = False
ruleArity :: CoreRule -> Int
ruleArity (BuiltinRule {ru_nargs = n}) = n
ruleArity (Rule {ru_args = args}) = length args
ruleName :: CoreRule -> RuleName
ruleName = ru_name
......
This diff is collapsed.
......@@ -482,7 +482,10 @@ occAnal env (Note note body)
occAnal env (Cast expr co)
= case occAnal env expr of { (usage, expr') ->
(usage, Cast expr' co)
(markRhsUds env True usage, Cast expr' co)
-- If we see let x = y `cast` co
-- then mark y as 'Many' so that we don't
-- immediately inline y again.
}
\end{code}
......@@ -581,23 +584,13 @@ the "build hack" to work.
occAnalApp env (Var fun, args) is_rhs
= case args_stuff of { (args_uds, args') ->
let
-- We mark the free vars of the argument of a constructor or PAP
-- as "many", if it is the RHS of a let(rec).
-- This means that nothing gets inlined into a constructor argument
-- position, which is what we want. Typically those constructor
-- arguments are just variables, or trivial expressions.
--
-- This is the *whole point* of the isRhsEnv predicate
final_args_uds
| isRhsEnv env,
isDataConWorkId fun || valArgCount args < idArity fun
= mapVarEnv markMany args_uds
| otherwise = args_uds
final_args_uds = markRhsUds env is_pap args_uds
in
(fun_uds +++ final_args_uds, mkApps (Var fun) args') }
where
fun_uniq = idUnique fun
fun_uds = mkOneOcc env fun (valArgCount args > 0)
is_pap = isDataConWorkId fun || valArgCount args < idArity fun
-- Hack for build, fold, runST
args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
......@@ -628,6 +621,23 @@ occAnalApp env (fun, args) is_rhs
in
(final_uds, mkApps fun' args') }}
markRhsUds :: OccEnv -- Check if this is a RhsEnv
-> Bool -- and this is true
-> UsageDetails -- The do markMany on this
-> UsageDetails
-- We mark the free vars of the argument of a constructor or PAP
-- as "many", if it is the RHS of a let(rec).
-- This means that nothing gets inlined into a constructor argument
-- position, which is what we want. Typically those constructor
-- arguments are just variables, or trivial expressions.
--
-- This is the *whole point* of the isRhsEnv predicate
markRhsUds env is_pap arg_uds
| isRhsEnv env && is_pap = mapVarEnv markMany arg_uds
| otherwise = arg_uds
appSpecial :: OccEnv
-> Int -> CtxtTy -- Argument number, and context to use for it
-> [CoreExpr]
......
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
......@@ -203,7 +203,7 @@ pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs)
\begin{code}
lookupRule :: (Activation -> Bool) -> InScopeSet
-> RuleBase -- Imported rules
-> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
-> Id -> [CoreExpr] -> Maybe (CoreRule, CoreExpr)
lookupRule is_active in_scope rule_base fn args
= matchRules is_active in_scope fn args rules
where
......@@ -217,13 +217,13 @@ lookupRule is_active in_scope rule_base fn args
matchRules :: (Activation -> Bool) -> InScopeSet
-> Id -> [CoreExpr]
-> [CoreRule] -> Maybe (RuleName, CoreExpr)
-> [CoreRule] -> Maybe (CoreRule, CoreExpr)
-- See comments on matchRule
matchRules is_active in_scope fn args rules
= case go [] rules of
= -- pprTrace "matchRules" (ppr fn <+> ppr rules) $
case go [] rules of
[] -> Nothing
(m:ms) -> Just (case findBest (fn,args) m ms of
(rule, ans) -> (ru_name rule, ans))
(m:ms) -> Just (findBest (fn,args) m ms)
where
rough_args = map roughTopName args
......@@ -231,7 +231,8 @@ matchRules is_active in_scope fn args rules
go ms [] = ms
go ms (r:rs) = case (matchRule is_active in_scope args rough_args r) of
Just e -> go ((r,e):ms) rs
Nothing -> go ms rs
Nothing -> -- pprTrace "Failed match" ((ppr r) $$ (ppr args)) $
go ms rs
findBest :: (Id, [CoreExpr])
-> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)
......@@ -309,11 +310,9 @@ matchRule is_active in_scope args rough_args
| ruleCantMatch tpl_tops rough_args = Nothing
| otherwise
= case matchN in_scope tpl_vars tpl_args args of
Nothing -> Nothing
Just (binds, tpl_vals, leftovers) -> Just (mkLets binds $
rule_fn
`mkApps` tpl_vals
`mkApps` leftovers)
Nothing -> Nothing
Just (binds, tpl_vals) -> Just (mkLets binds $
rule_fn `mkApps` tpl_vals)
where
rule_fn = occurAnalyseExpr (mkLams tpl_vars rhs)
-- We could do this when putting things into the rulebase, I guess
......@@ -325,20 +324,18 @@ matchN :: InScopeSet
-> [CoreExpr] -- Template
-> [CoreExpr] -- Target; can have more elts than template
-> Maybe ([CoreBind], -- Bindings to wrap around the entire result
[CoreExpr], -- What is substituted for each template var
[CoreExpr]) -- Leftover target exprs
[CoreExpr]) -- What is substituted for each template var
matchN in_scope tmpl_vars tmpl_es target_es
= do { ((tv_subst, id_subst, binds), leftover_es)
= do { (tv_subst, id_subst, binds)
<- go init_menv emptySubstEnv tmpl_es target_es
; return (fromOL binds,
map (lookup_tmpl tv_subst id_subst) tmpl_vars,
leftover_es) }
map (lookup_tmpl tv_subst id_subst) tmpl_vars) }
where
init_menv = ME { me_tmpls = mkVarSet tmpl_vars, me_env = init_rn_env }
init_rn_env = mkRnEnv2 (extendInScopeSetList in_scope tmpl_vars)
go menv subst [] es = Just (subst, es)
go menv subst [] es = Just subst
go menv subst ts [] = Nothing -- Fail if too few actual args
go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e
; go menv subst1 ts es }
......@@ -538,7 +535,8 @@ match menv subst e1 (Let bind e2)
-}
-- Everything else fails
match menv subst e1 e2 = Nothing
match menv subst e1 e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr e1) $$ (text "e2:" <+> ppr e2)) $
Nothing
------------------------------------------
match_var :: MatchEnv
......
......@@ -787,7 +787,8 @@ callToPats in_scope bndr_occs (con_env, args)
-- Quantify over variables that are not in sccpe
-- See Note [Shadowing] at the top
; if or good_pats
; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
if or good_pats
then return (Just (qvars, pats))
else return Nothing }
......
......@@ -21,6 +21,7 @@ module TcGadt (
import HsSyn
import Coercion
import Type
import TypeRep
import DataCon
import Var
......@@ -226,12 +227,15 @@ fixTvSubstEnv in_scope env
fixpt = mapVarEnv (substTy (mkTvSubst in_scope fixpt)) env
----------------------------
dataConCanMatch :: DataCon -> [Type] -> Bool
dataConCanMatch :: [Type] -> DataCon -> Bool
-- Returns True iff the data con can match a scrutinee of type (T tys)
-- where T is the type constructor for the data con
--
-- Instantiate the equations and try to unify them
dataConCanMatch con tys
dataConCanMatch tys con
| null eq_spec = True -- Common
| all isTyVarTy tys = True -- Also common
| otherwise
= isJust (tcUnifyTys (\tv -> BindMe)
(map (substTyVar subst . fst) eq_spec)
(map snd eq_spec))
......
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