From: Manuel M T Chakravarty Date: Thu, 9 Jun 2011 12:35:03 +0000 (+1000) Subject: Take vectorisation declarations into account during the initial occurrence analysis... X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=a1fae73a83665d7b9134509e80d34ff69a009cc7 Take vectorisation declarations into account during the initial occurrence analysis (right after desugaring). --- diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index 88509f9..c130921 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.lhs @@ -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 diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index 047e6c3..acf17e3 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -692,16 +692,16 @@ 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. @@ -709,13 +709,22 @@ substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args (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 diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 7b008e9..70679fb 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -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, diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index ba7d192..06133d6 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -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 _ [] diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index ea81317..23a2472 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -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); diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 8462403..2eefb8c 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -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 diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 7e7f117..545258c 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -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}