#include "HsVersions.h"
-import CmdLineOpts ( opt_D_dump_simpl, opt_D_verbose_core2core, opt_UsageSPOn )
+import CmdLineOpts ( DynFlags, DynFlag(..), opt_UsageSPOn, dopt )
import CoreSyn
import CoreUnfold ( noUnfolding )
import CoreLint ( beginPass, endPass )
-import Rules ( ProtoCoreRule(..) )
+import Rules ( ProtoCoreRule(..), RuleBase )
import UsageSPInf ( doUsageSPInf )
import VarEnv
import VarSet
-import Var ( Id, IdOrTyVar )
-import Id ( idType, idInfo, idName,
- mkVanillaId, mkId, isUserExportedId,
- getIdStrictness, setIdStrictness,
- getIdDemandInfo, setIdDemandInfo,
+import Var ( Id, Var )
+import Id ( idType, idInfo, idName, idSpecialisation,
+ mkVanillaId, mkId, exportWithOrigOccName,
+ idStrictness, setIdStrictness,
+ idDemandInfo, setIdDemandInfo,
)
import IdInfo ( specInfo, setSpecInfo,
- inlinePragInfo, setInlinePragInfo, InlinePragInfo(..),
- setUnfoldingInfo, setDemandInfo
+ setUnfoldingInfo, setDemandInfo,
+ workerInfo, setWorkerInfo, WorkerInfo(..)
)
import Demand ( wwLazy )
import Name ( getOccName, tidyTopName, mkLocalName, isLocallyDefined )
import OccName ( initTidyOccEnv, tidyOccName )
import Type ( tidyTopType, tidyType, tidyTypes, tidyTyVar, tidyTyVars )
import Module ( Module )
-import UniqSupply ( UniqSupply )
+import UniqSupply ( mkSplitUniqSupply )
import Unique ( Uniquable(..) )
import SrcLoc ( noSrcLoc )
import Util ( mapAccumL )
-import Outputable
\end{code}
Several tasks are done by @tidyCorePgm@
-1. Make certain top-level bindings into Globals. The point is that
+1. If @opt_UsageSPOn@ then compute usage information (which is
+ needed by Core2Stg). ** NOTE _scc_ HERE **
+ Do this first, because it may introduce new binders.
+
+2. Make certain top-level bindings into Globals. The point is that
Global things get externally-visible labels at code generation
time
-2. Give all binders a nice print-name. Their uniques aren't changed;
+3. Give all binders a nice print-name. Their uniques aren't changed;
rather we give them lexically unique occ-names, so that we can
safely print the OccNae only in the interface file. [Bad idea to
change the uniques, because the code generator makes global labels
from the uniques for local thunks etc.]
-
-3. If @opt_UsageSPOn@ then compute usage information (which is
- needed by Core2Stg). ** NOTE _scc_ HERE **
-
\begin{code}
-tidyCorePgm :: UniqSupply -> Module -> [CoreBind] -> [ProtoCoreRule]
+tidyCorePgm :: DynFlags -> Module -> [CoreBind] -> RuleBase
-> IO ([CoreBind], [ProtoCoreRule])
-tidyCorePgm us module_name binds_in rules
+tidyCorePgm dflags module_name binds_in rulebase_in
= do
- beginPass "Tidy Core"
+ us <- mkSplitUniqSupply 'u'
- let (tidy_env1, binds_tidy) = mapAccumL (tidyBind (Just module_name)) init_tidy_env binds_in
- rules_out = tidyProtoRules tidy_env1 rules
+ beginPass dflags "Tidy Core"
- binds_out <- if opt_UsageSPOn
- then _scc_ "CoreUsageSPInf" doUsageSPInf us binds_tidy
- else return binds_tidy
+ binds_in1 <- if opt_UsageSPOn
+ then _scc_ "CoreUsageSPInf"
+ doUsageSPInf dflags us binds_in rulebase_in
+ else return binds_in
+
+ let (tidy_env1, binds_out) = mapAccumL (tidyBind (Just module_name))
+ init_tidy_env binds_in1
+ rules_out = tidyProtoRules tidy_env1 (mk_local_protos rulebase_in)
+
+ endPass dflags "Tidy Core" (dopt Opt_D_dump_simpl dflags ||
+ dopt Opt_D_verbose_core2core dflags)
+ binds_out
- endPass "Tidy Core" (opt_D_dump_simpl || opt_D_verbose_core2core) binds_out
return (binds_out, rules_out)
where
-- We also make sure to avoid any exported binders. Consider
-- decl. tidyTopId then does a no-op on exported binders.
init_tidy_env = (initTidyOccEnv avoids, emptyVarEnv)
avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in,
- isUserExportedId bndr]
+ exportWithOrigOccName bndr]
+
+ mk_local_protos :: RuleBase -> [ProtoCoreRule]
+ mk_local_protos (rule_ids, _)
+ = [ProtoCoreRule True id rule | id <- varSetElems rule_ids,
+ rule <- rulesRules (idSpecialisation id)]
tidyBind :: Maybe Module -- (Just m) for top level, Nothing for nested
-> TidyEnv
-> (TidyEnv, CoreBind)
tidyBind maybe_mod env (NonRec bndr rhs)
= let
- (env', bndr') = tidy_bndr maybe_mod env bndr
- rhs' = tidyExpr env rhs
+ (env', bndr') = tidy_bndr maybe_mod env' env bndr
+ rhs' = tidyExpr env' rhs
+ -- We use env' when tidying the RHS even though it's not
+ -- strictly necessary; it makes the code pretty hard to read
+ -- if we don't!
in
(env', NonRec bndr' rhs')
-- So I left it out for now
(bndrs, rhss) = unzip pairs
- (env', bndrs') = mapAccumL (tidy_bndr maybe_mod) env bndrs
+ (env', bndrs') = mapAccumL (tidy_bndr maybe_mod env') env bndrs
rhss' = map (tidyExpr env') rhss
in
(env', Rec (zip bndrs' rhss'))
tidyExpr env (Type ty) = Type (tidyType env ty)
-tidyExpr env (Con con args) = Con con (map (tidyExpr env) args)
+tidyExpr env (Lit lit) = Lit lit
tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a)
tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e)
\end{code}
\begin{code}
-tidy_bndr (Just mod) env id = tidyTopId mod env id
-tidy_bndr Nothing env var = tidyBndr env var
+tidy_bndr (Just mod) env_idinfo env var = tidyTopId mod env env_idinfo var
+tidy_bndr Nothing env_idinfo env var = tidyBndr env var
\end{code}
%************************************************************************
\begin{code}
-tidyBndr :: TidyEnv -> IdOrTyVar -> (TidyEnv, IdOrTyVar)
+tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
tidyBndr env var | isTyVar var = tidyTyVar env var
| otherwise = tidyId env var
-tidyBndrs :: TidyEnv -> [IdOrTyVar] -> (TidyEnv, [IdOrTyVar])
+tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
tidyBndrs env vars = mapAccumL tidyBndr env vars
tidyId :: TidyEnv -> Id -> (TidyEnv, Id)
(tidy_env', occ') = tidyOccName tidy_env (getOccName id)
ty' = tidyType env (idType id)
id' = mkVanillaId name' ty'
- `setIdStrictness` getIdStrictness id
- `setIdDemandInfo` getIdDemandInfo id
+ `setIdStrictness` idStrictness id
+ `setIdDemandInfo` idDemandInfo id
-- NB: This throws away the IdInfo of the Id, which we
-- no longer need. That means we don't need to
-- run over it with env, nor renumber it.
in
((tidy_env', var_env'), id')
-tidyTopId :: Module -> TidyEnv -> Id -> (TidyEnv, Id)
-tidyTopId mod env@(tidy_env, var_env) id
+tidyTopId :: Module -> TidyEnv -> TidyEnv -> Id -> (TidyEnv, Id)
+ -- The second env is the one to use for the IdInfo
+ -- It's necessary because when we are dealing with a recursive
+ -- group, a variable late in the group might be mentioned
+ -- in the IdInfo of one early in the group
+tidyTopId mod env@(tidy_env, var_env) env_idinfo id
= -- Top level variables
let
- (tidy_env', name') | isUserExportedId id = (tidy_env, idName id)
- | otherwise = tidyTopName mod tidy_env (idName id)
+ (tidy_env', name') | exportWithOrigOccName id = (tidy_env, idName id)
+ | otherwise = tidyTopName mod tidy_env (idName id)
ty' = tidyTopType (idType id)
- idinfo' = tidyIdInfo env (idInfo id)
+ idinfo' = tidyIdInfo env_idinfo (idInfo id)
id' = mkId name' ty' idinfo'
var_env' = extendVarEnv var_env id id'
in
\begin{code}
-- tidyIdInfo does these things:
--- a) tidy the specialisation info (if any)
--- b) zap a complicated ICanSafelyBeINLINEd pragma,
--- c) zap the unfolding
+-- a) tidy the specialisation info and worker info (if any)
+-- b) zap the unfolding and demand info
-- The latter two are to avoid space leaks
tidyIdInfo env info
- = info4
+ = info5
where
rules = specInfo info
- info1 | isEmptyCoreRules rules = info
+ info2 | isEmptyCoreRules rules = info
| otherwise = info `setSpecInfo` tidyRules env rules
- info2 = case inlinePragInfo info of
- ICanSafelyBeINLINEd _ _ -> info1 `setInlinePragInfo` NoInlinePragInfo
- other -> info1
-
info3 = info2 `setUnfoldingInfo` noUnfolding
info4 = info3 `setDemandInfo` wwLazy -- I don't understand why...
+ info5 = case workerInfo info of
+ NoWorker -> info4
+ HasWorker w a -> info4 `setWorkerInfo` HasWorker (tidyVarOcc env w) a
+
tidyProtoRules :: TidyEnv -> [ProtoCoreRule] -> [ProtoCoreRule]
tidyProtoRules env rules
= [ ProtoCoreRule is_local (tidyVarOcc env fn) (tidyRule env rule)
tidy_set_elem var new_set = extendVarSet new_set (tidyVarOcc env var)
tidyRule :: TidyEnv -> CoreRule -> CoreRule
+tidyRule env rule@(BuiltinRule _) = rule
tidyRule env (Rule name vars tpl_args rhs)
= (Rule name vars' (map (tidyExpr env') tpl_args) (tidyExpr env' rhs))
where
projects / ghc-hetmet.git / blobdiff