2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section{Tidying up Core}
12 #include "HsVersions.h"
14 import CmdLineOpts ( opt_D_dump_simpl, opt_D_verbose_core2core, opt_UsageSPOn )
16 import CoreUnfold ( noUnfolding )
17 import CoreLint ( beginPass, endPass )
18 import Rules ( ProtoCoreRule(..) )
19 import UsageSPInf ( doUsageSPInf )
22 import Var ( Id, IdOrTyVar )
23 import Id ( idType, idInfo, idName,
24 mkVanillaId, mkId, isUserExportedId,
25 getIdStrictness, setIdStrictness,
26 getIdDemandInfo, setIdDemandInfo,
28 import IdInfo ( specInfo, setSpecInfo,
29 inlinePragInfo, setInlinePragInfo, InlinePragInfo(..),
30 setUnfoldingInfo, setDemandInfo
32 import Demand ( wwLazy )
33 import Name ( getOccName, tidyTopName, mkLocalName, isLocallyDefined )
34 import OccName ( initTidyOccEnv, tidyOccName )
35 import Type ( tidyTopType, tidyType, tidyTypes, tidyTyVar, tidyTyVars )
36 import Module ( Module )
37 import UniqSupply ( UniqSupply )
38 import Unique ( Uniquable(..) )
39 import SrcLoc ( noSrcLoc )
40 import Util ( mapAccumL )
46 %************************************************************************
48 \subsection{Tidying core}
50 %************************************************************************
52 Several tasks are done by @tidyCorePgm@
54 1. Make certain top-level bindings into Globals. The point is that
55 Global things get externally-visible labels at code generation
59 2. Give all binders a nice print-name. Their uniques aren't changed;
60 rather we give them lexically unique occ-names, so that we can
61 safely print the OccNae only in the interface file. [Bad idea to
62 change the uniques, because the code generator makes global labels
63 from the uniques for local thunks etc.]
66 3. If @opt_UsageSPOn@ then compute usage information (which is
67 needed by Core2Stg). ** NOTE _scc_ HERE **
70 tidyCorePgm :: UniqSupply -> Module -> [CoreBind] -> [ProtoCoreRule]
71 -> IO ([CoreBind], [ProtoCoreRule])
72 tidyCorePgm us module_name binds_in rules
76 let (tidy_env1, binds_tidy) = mapAccumL (tidyBind (Just module_name)) init_tidy_env binds_in
77 rules_out = tidyProtoRules tidy_env1 rules
79 binds_out <- if opt_UsageSPOn
80 then _scc_ "CoreUsageSPInf" doUsageSPInf us binds_tidy
81 else return binds_tidy
83 endPass "Tidy Core" (opt_D_dump_simpl || opt_D_verbose_core2core) binds_out
84 return (binds_out, rules_out)
86 -- We also make sure to avoid any exported binders. Consider
87 -- f{-u1-} = 1 -- Local decl
89 -- f{-u2-} = 2 -- Exported decl
91 -- The second exported decl must 'get' the name 'f', so we
92 -- have to put 'f' in the avoids list before we get to the first
93 -- decl. tidyTopId then does a no-op on exported binders.
94 init_tidy_env = (initTidyOccEnv avoids, emptyVarEnv)
95 avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in,
96 isUserExportedId bndr]
98 tidyBind :: Maybe Module -- (Just m) for top level, Nothing for nested
101 -> (TidyEnv, CoreBind)
102 tidyBind maybe_mod env (NonRec bndr rhs)
104 (env', bndr') = tidy_bndr maybe_mod env bndr
105 rhs' = tidyExpr env rhs
107 (env', NonRec bndr' rhs')
109 tidyBind maybe_mod env (Rec pairs)
111 -- We use env' when tidying the rhss
112 -- When tidying the binder itself we may tidy it's
113 -- specialisations; if any of these mention other binders
114 -- in the group we should really feed env' to them too;
115 -- but that seems (a) unlikely and (b) a bit tiresome.
116 -- So I left it out for now
118 (bndrs, rhss) = unzip pairs
119 (env', bndrs') = mapAccumL (tidy_bndr maybe_mod) env bndrs
120 rhss' = map (tidyExpr env') rhss
122 (env', Rec (zip bndrs' rhss'))
124 tidyExpr env (Type ty) = Type (tidyType env ty)
125 tidyExpr env (Con con args) = Con con (map (tidyExpr env) args)
126 tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a)
127 tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e)
129 tidyExpr env (Let b e) = Let b' (tidyExpr env' e)
131 (env', b') = tidyBind Nothing env b
133 tidyExpr env (Case e b alts) = Case (tidyExpr env e) b' (map (tidyAlt env') alts)
135 (env', b') = tidyBndr env b
137 tidyExpr env (Var v) = Var (tidyVarOcc env v)
139 tidyExpr env (Lam b e) = Lam b' (tidyExpr env' e)
141 (env', b') = tidyBndr env b
143 tidyAlt env (con, vs, rhs) = (con, vs', tidyExpr env' rhs)
145 (env', vs') = tidyBndrs env vs
147 tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2)
149 tidyNote env note = note
151 tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of
157 tidy_bndr (Just mod) env id = tidyTopId mod env id
158 tidy_bndr Nothing env var = tidyBndr env var
163 %************************************************************************
165 \subsection{Tidying up a binder}
167 %************************************************************************
170 tidyBndr :: TidyEnv -> IdOrTyVar -> (TidyEnv, IdOrTyVar)
171 tidyBndr env var | isTyVar var = tidyTyVar env var
172 | otherwise = tidyId env var
174 tidyBndrs :: TidyEnv -> [IdOrTyVar] -> (TidyEnv, [IdOrTyVar])
175 tidyBndrs env vars = mapAccumL tidyBndr env vars
177 tidyId :: TidyEnv -> Id -> (TidyEnv, Id)
178 tidyId env@(tidy_env, var_env) id
179 = -- Non-top-level variables
181 -- Give the Id a fresh print-name, *and* rename its type
182 -- The SrcLoc isn't important now, though we could extract it from the Id
183 name' = mkLocalName (getUnique id) occ' noSrcLoc
184 (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
185 ty' = tidyType env (idType id)
186 id' = mkVanillaId name' ty'
187 `setIdStrictness` getIdStrictness id
188 `setIdDemandInfo` getIdDemandInfo id
189 -- NB: This throws away the IdInfo of the Id, which we
190 -- no longer need. That means we don't need to
191 -- run over it with env, nor renumber it.
193 -- The exception is strictness and demand info, which
194 -- is used to decide whether to use let or case for
195 -- function arguments and let bindings
197 var_env' = extendVarEnv var_env id id'
199 ((tidy_env', var_env'), id')
201 tidyTopId :: Module -> TidyEnv -> Id -> (TidyEnv, Id)
202 tidyTopId mod env@(tidy_env, var_env) id
203 = -- Top level variables
205 (tidy_env', name') | isUserExportedId id = (tidy_env, idName id)
206 | otherwise = tidyTopName mod tidy_env (idName id)
207 ty' = tidyTopType (idType id)
208 idinfo' = tidyIdInfo env (idInfo id)
209 id' = mkId name' ty' idinfo'
210 var_env' = extendVarEnv var_env id id'
212 ((tidy_env', var_env'), id')
216 -- tidyIdInfo does these things:
217 -- a) tidy the specialisation info (if any)
218 -- b) zap a complicated ICanSafelyBeINLINEd pragma,
219 -- c) zap the unfolding
220 -- The latter two are to avoid space leaks
225 rules = specInfo info
227 info1 | isEmptyCoreRules rules = info
228 | otherwise = info `setSpecInfo` tidyRules env rules
230 info2 = case inlinePragInfo info of
231 ICanSafelyBeINLINEd _ _ -> info1 `setInlinePragInfo` NoInlinePragInfo
234 info3 = info2 `setUnfoldingInfo` noUnfolding
235 info4 = info3 `setDemandInfo` wwLazy -- I don't understand why...
237 tidyProtoRules :: TidyEnv -> [ProtoCoreRule] -> [ProtoCoreRule]
238 tidyProtoRules env rules
239 = [ ProtoCoreRule is_local (tidyVarOcc env fn) (tidyRule env rule)
240 | ProtoCoreRule is_local fn rule <- rules
243 tidyRules :: TidyEnv -> CoreRules -> CoreRules
244 tidyRules env (Rules rules fvs)
245 = Rules (map (tidyRule env) rules)
246 (foldVarSet tidy_set_elem emptyVarSet fvs)
248 tidy_set_elem var new_set = extendVarSet new_set (tidyVarOcc env var)
250 tidyRule :: TidyEnv -> CoreRule -> CoreRule
251 tidyRule env (Rule name vars tpl_args rhs)
252 = (Rule name vars' (map (tidyExpr env') tpl_args) (tidyExpr env' rhs))
254 (env', vars') = tidyBndrs env vars