Commit a1fae73a authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Take vectorisation declarations into account during the initial occurrence...

Take vectorisation declarations into account during the initial occurrence analysis (right after desugaring).
parent 75f9f355
......@@ -15,27 +15,28 @@ Taken quite directly from the Peyton Jones/Lester paper.
-- | A module concerned with finding the free variables of an expression.
module CoreFVs (
-- * Free variables of expressions and binding groups
exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars
exprFreeIds, -- CoreExpr -> IdSet -- Find all locally-defined free Ids
exprsFreeVars, -- [CoreExpr] -> VarSet
bindFreeVars, -- CoreBind -> VarSet
exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars
exprFreeIds, -- CoreExpr -> IdSet -- Find all locally-defined free Ids
exprsFreeVars, -- [CoreExpr] -> VarSet
bindFreeVars, -- CoreBind -> VarSet
-- * Selective free variables of expressions
InterestingVarFun,
exprSomeFreeVars, exprsSomeFreeVars,
exprSomeFreeVars, exprsSomeFreeVars,
-- * Free variables of Rules, Vars and Ids
varTypeTyVars, varTypeTcTyVars,
idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
idRuleVars, idRuleRhsVars, stableUnfoldingVars,
ruleRhsFreeVars, rulesFreeVars,
ruleLhsOrphNames, ruleLhsFreeIds,
ruleRhsFreeVars, rulesFreeVars,
ruleLhsOrphNames, ruleLhsFreeIds,
vectsFreeVars,
-- * Core syntax tree annotation with free variables
CoreExprWithFVs, -- = AnnExpr Id VarSet
CoreBindWithFVs, -- = AnnBind Id VarSet
freeVars, -- CoreExpr -> CoreExprWithFVs
freeVarsOf -- CoreExprWithFVs -> IdSet
CoreExprWithFVs, -- = AnnExpr Id VarSet
CoreBindWithFVs, -- = AnnBind Id VarSet
freeVars, -- CoreExpr -> CoreExprWithFVs
freeVarsOf -- CoreExprWithFVs -> IdSet
) where
#include "HsVersions.h"
......@@ -268,9 +269,9 @@ exprsOrphNames es = foldr (unionNameSets . exprOrphNames) emptyNameSet es
\end{code}
%************************************************************************
%* *
%* *
\section[freevars-everywhere]{Attaching free variables to every sub-expression}
%* *
%* *
%************************************************************************
\begin{code}
......@@ -278,7 +279,7 @@ exprsOrphNames es = foldr (unionNameSets . exprOrphNames) emptyNameSet es
ruleRhsFreeVars :: CoreRule -> VarSet
ruleRhsFreeVars (BuiltinRule {}) = noFVs
ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs })
= delFromUFM fvs fn -- Note [Rule free var hack]
= delFromUFM fvs fn -- Note [Rule free var hack]
where
fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
......@@ -286,7 +287,7 @@ ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs })
ruleFreeVars :: CoreRule -> VarSet
ruleFreeVars (BuiltinRule {}) = noFVs
ruleFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args })
= delFromUFM fvs fn -- Note [Rule free var hack]
= delFromUFM fvs fn -- Note [Rule free var hack]
where
fvs = addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet
......@@ -298,8 +299,8 @@ idRuleRhsVars is_active id
get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs
, ru_rhs = rhs, ru_act = act })
| is_active act
-- See Note [Finding rule RHS free vars] in OccAnal.lhs
= delFromUFM fvs fn -- Note [Rule free var hack]
-- See Note [Finding rule RHS free vars] in OccAnal.lhs
= delFromUFM fvs fn -- Note [Rule free var hack]
where
fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
get_fvs _ = noFVs
......@@ -315,19 +316,31 @@ ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
= addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet
\end{code}
Note [Rule free var hack]
~~~~~~~~~~~~~~~~~~~~~~~~~
Don't include the Id in its own rhs free-var set.
Otherwise the occurrence analyser makes bindings recursive
that shoudn't be. E.g.
RULE: f (f x y) z ==> f x (f y z)
RULE: f (f x y) z ==> f x (f y z)
Also since rule_fn is a Name, not a Var, we have to use the grungy delUFM.
\begin{code}
-- |Free variables of a vectorisation declaration
vectsFreeVars :: [CoreVect] -> VarSet
vectsFreeVars = foldr (unionVarSet . vectFreeVars) emptyVarSet
where
vectFreeVars (Vect _ Nothing) = noFVs
vectFreeVars (Vect _ (Just rhs)) = expr_fvs rhs isLocalId emptyVarSet
\end{code}
%************************************************************************
%* *
%* *
\section[freevars-everywhere]{Attaching free variables to every sub-expression}
%* *
%* *
%************************************************************************
The free variable pass annotates every node in the expression with its
......
......@@ -692,30 +692,39 @@ substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule
-- - Rules for *imported* Ids never change ru_fn
-- - Rules for *local* Ids are in the IdInfo for that Id,
-- and the ru_fn field is simply replaced by the new name
-- of the Id
-- of the Id
substRule _ _ rule@(BuiltinRule {}) = rule
substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
, ru_fn = fn_name, ru_rhs = rhs
, ru_local = is_local })
= rule { ru_bndrs = bndrs',
ru_fn = if is_local
then subst_ru_fn fn_name
else fn_name,
ru_args = map (substExpr (text "subst-rule" <+> ppr fn_name) subst') args,
ru_fn = if is_local
then subst_ru_fn fn_name
else fn_name,
ru_args = map (substExpr (text "subst-rule" <+> ppr fn_name) subst') args,
ru_rhs = simpleOptExprWith subst' rhs }
-- Do simple optimisation on RHS, in case substitution lets
-- you improve it. The real simplifier never gets to look at it.
where
(subst', bndrs') = substBndrs subst bndrs
------------------
substVects :: Subst -> [CoreVect] -> [CoreVect]
substVects subst = map (substVect subst)
------------------
substVect :: Subst -> CoreVect -> CoreVect
substVect _subst (Vect v Nothing) = Vect v Nothing
substVect subst (Vect v (Just rhs)) = Vect v (Just (simpleOptExprWith subst rhs))
------------------
substVarSet :: Subst -> VarSet -> VarSet
substVarSet subst fvs
= foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
where
subst_fv subst fv
| isId fv = exprFreeVars (lookupIdSubst (text "substVarSet") subst fv)
| otherwise = Type.tyVarsOfType (lookupTvSubst subst fv)
| isId fv = exprFreeVars (lookupIdSubst (text "substVarSet") subst fv)
| otherwise = Type.tyVarsOfType (lookupTvSubst subst fv)
\end{code}
Note [Worker inlining]
......@@ -766,15 +775,16 @@ simpleOptExprWith :: Subst -> InExpr -> OutExpr
simpleOptExprWith subst expr = simple_opt_expr subst (occurAnalyseExpr expr)
----------------------
simpleOptPgm :: DynFlags -> [CoreBind] -> [CoreRule] -> IO ([CoreBind], [CoreRule])
simpleOptPgm dflags binds rules
simpleOptPgm :: DynFlags -> [CoreBind] -> [CoreRule] -> [CoreVect]
-> IO ([CoreBind], [CoreRule], [CoreVect])
simpleOptPgm dflags binds rules vects
= do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
(pprCoreBindings occ_anald_binds);
(pprCoreBindings occ_anald_binds);
; return (reverse binds', substRulesForImportedIds subst' rules) }
; return (reverse binds', substRulesForImportedIds subst' rules, substVects subst' vects) }
where
occ_anald_binds = occurAnalysePgm Nothing {- No rules active -}
rules binds
rules vects binds
(subst', binds') = foldl do_one (emptySubst, []) occ_anald_binds
do_one (subst, binds') bind
......
......@@ -116,35 +116,36 @@ deSugar hsc_env
; case mb_res of {
Nothing -> return (msgs, Nothing) ;
Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks) -> do
Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks) -> do
{ -- Add export flags to bindings
keep_alive <- readIORef keep_var
; let (rules_for_locals, rules_for_imps)
{ -- Add export flags to bindings
keep_alive <- readIORef keep_var
; let (rules_for_locals, rules_for_imps)
= partition isLocalRule all_rules
final_prs = addExportFlagsAndRules target
export_set keep_alive rules_for_locals (fromOL all_prs)
export_set keep_alive rules_for_locals (fromOL all_prs)
final_pgm = combineEvBinds ds_ev_binds final_prs
-- Notice that we put the whole lot in a big Rec, even the foreign binds
-- When compiling PrelFloat, which defines data Float = F# Float#
-- we want F# to be in scope in the foreign marshalling code!
-- You might think it doesn't matter, but the simplifier brings all top-level
-- things into the in-scope set before simplifying; so we get no unfolding for F#!
-- Notice that we put the whole lot in a big Rec, even the foreign binds
-- When compiling PrelFloat, which defines data Float = F# Float#
-- we want F# to be in scope in the foreign marshalling code!
-- You might think it doesn't matter, but the simplifier brings all top-level
-- things into the in-scope set before simplifying; so we get no unfolding for F#!
-- Lint result if necessary, and print
-- Lint result if necessary, and print
; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
(vcat [ pprCoreBindings final_pgm
, pprRules rules_for_imps ])
; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps
-- The simpleOptPgm gets rid of type
-- bindings plus any stupid dead code
; (ds_binds, ds_rules_for_imps, ds_vects)
<- simpleOptPgm dflags final_pgm rules_for_imps vects0
-- The simpleOptPgm gets rid of type
-- bindings plus any stupid dead code
; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
; let used_names = mkUsedNames tcg_env
; deps <- mkDependencies tcg_env
; deps <- mkDependencies tcg_env
; let mod_guts = ModGuts {
mg_module = mod,
......
......@@ -53,13 +53,14 @@ import Data.List
Here's the externally-callable interface:
\begin{code}
occurAnalysePgm :: Maybe (Activation -> Bool) -> [CoreRule]
occurAnalysePgm :: Maybe (Activation -> Bool) -> [CoreRule] -> [CoreVect]
-> [CoreBind] -> [CoreBind]
occurAnalysePgm active_rule imp_rules binds
occurAnalysePgm active_rule imp_rules vects binds
= snd (go (initOccEnv active_rule imp_rules) binds)
where
initial_uds = addIdOccs emptyDetails (rulesFreeVars imp_rules)
-- The RULES keep things alive!
initial_uds = addIdOccs emptyDetails
(rulesFreeVars imp_rules `unionVarSet` vectsFreeVars vects)
-- The RULES and VECTORISE declarations keep things alive!
go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
go _ []
......
......@@ -358,7 +358,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
= do {
-- Occurrence analysis
let { tagged_binds = {-# SCC "OccAnal" #-}
occurAnalysePgm active_rule rules binds } ;
occurAnalysePgm active_rule rules [] binds } ;
Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
(pprCoreBindings tagged_binds);
......
......@@ -575,12 +575,13 @@ impSpecErr name
, ptext (sLit "(or you compiled its defining module without -O)")])
--------------
tcVectDecls :: [LVectDecl Name] -> TcM [LVectDecl TcId]
tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
tcVectDecls decls
= do { decls' <- mapM (wrapLocM tcVect) decls
; let ids = [unLoc id | L _ (HsVect id _) <- decls']
dups = findDupsEq (==) ids
; mapM_ reportVectDups dups
; traceTcConstraints "End of tcVectDecls"
; return decls'
}
where
......@@ -598,7 +599,7 @@ tcVect :: VectDecl Name -> TcM (VectDecl TcId)
tcVect (HsVect name Nothing)
= addErrCtxt (vectCtxt name) $
do { id <- wrapLocM tcLookupId name
; return (HsVect id Nothing)
; return $ HsVect id Nothing
}
tcVect (HsVect name@(L loc _) (Just rhs))
= addErrCtxt (vectCtxt name) $
......@@ -613,9 +614,10 @@ tcVect (HsVect name@(L loc _) (Just rhs))
; (binds, [id']) <- tcPolyInfer TopLevel False sigFun pragFun NonRecursive [bind]
; traceTc "tcVect inferred type" $ ppr (varType id')
; traceTc "tcVect bindings" $ ppr binds
-- add the type variable and dictionary bindings produced by type generalisation to the
-- right-hand side of the vectorisation declaration
-- add all bindings, including the type variable and dictionary bindings produced by type
-- generalisation to the right-hand side of the vectorisation declaration
; let [AbsBinds tvs evs _ evBinds actualBinds] = (map unLoc . bagToList) binds
; let [bind'] = bagToList actualBinds
MatchGroup
......
......@@ -989,10 +989,10 @@ captureConstraints :: TcM a -> TcM (a, WantedConstraints)
-- (captureConstraints m) runs m, and returns the type constraints it generates
captureConstraints thing_inside
= do { lie_var <- newTcRef emptyWC ;
res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
thing_inside ;
lie <- readTcRef lie_var ;
return (res, lie) }
res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
thing_inside ;
lie <- readTcRef lie_var ;
return (res, lie) }
captureUntouchables :: TcM a -> TcM (a, Untouchables)
captureUntouchables thing_inside
......@@ -1017,14 +1017,21 @@ setLclTypeEnv lcl_env thing_inside
= updLclEnv upd thing_inside
where
upd env = env { tcl_env = tcl_env lcl_env,
tcl_tyvars = tcl_tyvars lcl_env }
tcl_tyvars = tcl_tyvars lcl_env }
traceTcConstraints :: String -> TcM ()
traceTcConstraints msg
= do { lie_var <- getConstraintVar
; lie <- readTcRef lie_var
; traceTc (msg ++ "LIE:") (ppr lie)
}
\end{code}
%************************************************************************
%* *
Template Haskell context
%* *
%* *
Template Haskell context
%* *
%************************************************************************
\begin{code}
......
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