TidyPgm.lhs 44.9 KB
 Simon Marlow committed Nov 06, 2007 1   simonpj committed Mar 20, 2002 2 3 4 5 6 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section{Tidying up Core} \begin{code}  simonpj@microsoft.com committed Jan 02, 2009 7 8 module TidyPgm( mkBootModDetailsDs, mkBootModDetailsTc, tidyProgram, globaliseAndTidyId ) where  simonpj committed Mar 20, 2002 9 10 11  #include "HsVersions.h"  Simon Marlow committed Nov 06, 2007 12 13 import TcRnTypes import FamInstEnv  Simon Marlow committed Nov 06, 2007 14 import DynFlags  simonpj committed Mar 20, 2002 15 import CoreSyn  Simon Marlow committed Nov 06, 2007 16 17 18 import CoreUnfold import CoreFVs import CoreTidy  simonpj@microsoft.com committed Oct 29, 2009 19 import CoreMonad  Simon Marlow committed Nov 06, 2007 20 import CoreUtils  simonpj@microsoft.com committed Dec 24, 2009 21 import Rules  22 import CoreArity ( exprArity, exprBotStrictness_maybe )  simonpj@microsoft.com committed Sep 13, 2010 23 import Class ( classAllSelIds )  simonpj committed Mar 20, 2002 24 25 import VarEnv import VarSet  26 import Var  Simon Marlow committed Nov 06, 2007 27 28 29 import Id import IdInfo import InstEnv  simonpj@microsoft.com committed Nov 19, 2009 30 import Demand  Simon Marlow committed Nov 06, 2007 31 import BasicTypes  rl@cse.unsw.edu.au committed Oct 17, 2009 32 import Name hiding (varName)  Simon Marlow committed Nov 06, 2007 33 34 35 36 37 38 import NameSet import IfaceEnv import NameEnv import TcType import DataCon import TyCon  Simon Marlow committed Oct 03, 2007 39 import Module  simonpj@microsoft.com committed Sep 22, 2010 40 import Packages( isDllName )  Simon Marlow committed Oct 11, 2006 41 import HscTypes  Simon Marlow committed Nov 06, 2007 42 43 import Maybes import UniqSupply  simonpj committed Mar 20, 2002 44 import Outputable  Ian Lynagh committed Jan 13, 2008 45 import FastBool hiding ( fastOr )  Simon Marlow committed Jul 20, 2009 46 import Util  simonpj@microsoft.com committed Dec 24, 2009 47 import FastString  Simon Marlow committed Oct 11, 2006 48   simonpj@microsoft.com committed Mar 31, 2011 49 import Control.Monad ( when )  Simon Marlow committed Jul 20, 2009 50 import Data.List ( sortBy )  Simon Marlow committed Oct 11, 2006 51 import Data.IORef ( IORef, readIORef, writeIORef )  simonpj committed Mar 20, 2002 52 53 54 \end{code}  rl@cse.unsw.edu.au committed Oct 17, 2009 55 56 57 Constructing the TypeEnv, Instances, Rules, VectInfo from which the ModIface is constructed, and which goes on to subsequent modules in --make mode.  simonpj committed Apr 28, 2005 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79  Most of the interface file is obtained simply by serialising the TypeEnv. One important consequence is that if the *interface file* has pragma info if and only if the final TypeEnv does. This is not so important for *this* module, but it's essential for ghc --make: subsequent compilations must not see (e.g.) the arity if the interface file does not contain arity If they do, they'll exploit the arity; then the arity might change, but the iface file doesn't change => recompilation does not happen => disaster. For data types, the final TypeEnv will have a TyThing for the TyCon, plus one for each DataCon; the interface file will contain just one data type declaration, but it is de-serialised back into a collection of TyThings. %************************************************************************ %* * Plan A: simpleTidyPgm %* * %************************************************************************  simonpj committed Apr 28, 2005 80 Plan A: mkBootModDetails: omit pragmas, make interfaces small  simonpj committed Apr 28, 2005 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Ignore the bindings * Drop all WiredIn things from the TypeEnv (we never want them in interface files) * Retain all TyCons and Classes in the TypeEnv, to avoid having to find which ones are mentioned in the types of exported Ids * Trim off the constructors of non-exported TyCons, both from the TyCon and from the TypeEnv * Drop non-exported Ids from the TypeEnv * Tidy the types of the DFunIds of Instances, make them into GlobalIds, (they already have External Names) and add them to the TypeEnv * Tidy the types of the (exported) Ids in the TypeEnv, make them into GlobalIds (they already have External Names) * Drop rules altogether  simonpj committed Apr 28, 2005 105 106 107 108 * Tidy the bindings, to ensure that the Caf and Arity information is correct for each top-level binder; the code generator needs it. And to ensure that local names have distinct OccNames in case of object-file splitting  simonpj committed Apr 28, 2005 109 110 111 112  \begin{code} -- This is Plan A: make a small type env when typechecking only, -- or when compiling a hs-boot file, or simply when not using -O  simonpj committed Apr 28, 2005 113 114 115 -- -- We don't look at the bindings at all -- there aren't any -- for hs-boot files  simonpj committed Apr 28, 2005 116   Simon Marlow committed Nov 06, 2007 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails mkBootModDetailsTc hsc_env TcGblEnv{ tcg_exports = exports, tcg_type_env = type_env, tcg_insts = insts, tcg_fam_insts = fam_insts } = mkBootModDetails hsc_env exports type_env insts fam_insts mkBootModDetailsDs :: HscEnv -> ModGuts -> IO ModDetails mkBootModDetailsDs hsc_env ModGuts{ mg_exports = exports, mg_types = type_env, mg_insts = insts, mg_fam_insts = fam_insts } = mkBootModDetails hsc_env exports type_env insts fam_insts mkBootModDetails :: HscEnv -> [AvailInfo] -> NameEnv TyThing -> [Instance] -> [FamInstEnv.FamInst] -> IO ModDetails mkBootModDetails hsc_env exports type_env insts fam_insts  simonpj committed Apr 28, 2005 138  = do { let dflags = hsc_dflags hsc_env  simonpj@microsoft.com committed Dec 24, 2009 139  ; showPass dflags CoreTidy  simonpj committed Apr 28, 2005 140   simonpj@microsoft.com committed Jan 02, 2009 141  ; let { insts' = tidyInstances globaliseAndTidyId insts  simonpj@microsoft.com committed Nov 23, 2007 142 143 144  ; dfun_ids = map instanceDFunId insts' ; type_env1 = tidyBootTypeEnv (availsToNameSet exports) type_env ; type_env' = extendTypeEnvWithIds type_env1 dfun_ids  simonpj committed Apr 28, 2005 145  }  chak@cse.unsw.edu.au. committed Oct 10, 2006 146 147 148 149  ; return (ModDetails { md_types = type_env' , md_insts = insts' , md_fam_insts = fam_insts , md_rules = []  simonpj@microsoft.com committed Oct 30, 2008 150  , md_anns = []  mnislaih committed Dec 10, 2006 151  , md_exports = exports  chak@cse.unsw.edu.au. committed May 07, 2007 152  , md_vect_info = noVectInfo  Simon Marlow committed Apr 17, 2007 153  })  simonpj committed Apr 28, 2005 154  }  simonpj committed Apr 29, 2005 155 156  where  simonpj@microsoft.com committed Nov 23, 2007 157 158 tidyBootTypeEnv :: NameSet -> TypeEnv -> TypeEnv tidyBootTypeEnv exports type_env  simonpj@microsoft.com committed Jul 07, 2008 159  = tidyTypeEnv True False exports type_env final_ids  simonpj@microsoft.com committed Nov 23, 2007 160 161 162 163 164 165 166 167  where -- Find the LocalIds in the type env that are exported -- Make them into GlobalIds, and tidy their types -- -- It's very important to remove the non-exported ones -- because we don't tidy the OccNames, and if we don't remove -- the non-exported ones we'll get many things with the -- same name in the interface file, giving chaos.  simonpj@microsoft.com committed Jan 02, 2009 168  final_ids = [ globaliseAndTidyId id  simonpj@microsoft.com committed Nov 23, 2007 169 170 171 172 173 174 175 176  | id <- typeEnvIds type_env , isLocalId id , keep_it id ] -- default methods have their export flag set, but everything -- else doesn't (yet), because this is pre-desugaring, so we -- must test both. keep_it id = isExportedId id || idName id elemNameSet exports  simonpj committed Apr 28, 2005 177 178   simonpj@microsoft.com committed Jan 02, 2009 179 180  globaliseAndTidyId :: Id -> Id  simonpj committed Apr 28, 2005 181 -- Takes an LocalId with an External Name,  simonpj@microsoft.com committed Jan 02, 2009 182 183 184 185 186 187 188 189 -- makes it into a GlobalId -- * unchanged Name (might be Internal or External) -- * unchanged details -- * VanillaIdInfo (makes a conservative assumption about Caf-hood) globaliseAndTidyId id = Id.setIdType (globaliseId id) tidy_type where tidy_type = tidyTopType (idType id)  simonpj committed Apr 28, 2005 190 191 192 \end{code}  simonpj committed Mar 20, 2002 193 194 %************************************************************************ %* *  simonpj committed Apr 28, 2005 195  Plan B: tidy bindings, make TypeEnv full of IdInfo  simonpj committed Mar 20, 2002 196 197 198 %* * %************************************************************************  simonpj committed Apr 28, 2005 199 200 201 202 203 Plan B: include pragmas, make interfaces ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Figure out which Ids are externally visible * Tidy the bindings, externalising appropriate Ids  simonpj committed Mar 20, 2002 204   simonpj committed Apr 28, 2005 205 206 207 * Drop all Ids from the TypeEnv, and add all the External Ids from the bindings. (This adds their IdInfo to the TypeEnv; and adds floated-out Ids that weren't even in the TypeEnv before.)  simonpj committed Mar 20, 2002 208 209 210  Step 1: Figure out external Ids ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  Simon Marlow committed Jul 20, 2009 211 212 Note [choosing external names]  Simon Marlow committed Jul 23, 2009 213 214 215 216 See also the section "Interface stability" in the RecompilationAvoidance commentary: http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance  simonpj committed Mar 20, 2002 217 218 219 220 221 222 223 First we figure out which Ids are "external" Ids. An "external" Id is one that is visible from outside the compilation unit. These are a) the user exported ones b) ones mentioned in the unfoldings, workers, or rules of externally-visible ones  Simon Marlow committed Jul 20, 2009 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 While figuring out which Ids are external, we pick a "tidy" OccName for each one. That is, we make its OccName distinct from the other external OccNames in this module, so that in interface files and object code we can refer to it unambiguously by its OccName. The OccName for each binder is prefixed by the name of the exported Id that references it; e.g. if "f" references "x" in its unfolding, then "x" is renamed to "f_x". This helps distinguish the different "x"s from each other, and means that if "f" is later removed, things that depend on the other "x"s will not need to be recompiled. Of course, if there are multiple "f_x"s, then we have to disambiguate somehow; we use "f_x0", "f_x1" etc. As far as possible we should assign names in a deterministic fashion. Each time this module is compiled with the same options, we should end up with the same set of external names with the same types. That is, the ABI hash in the interface should not change. This turns out to be quite tricky, since the order of the bindings going into the tidy phase is already non-deterministic, as it is based on the ordering of Uniques, which are assigned unpredictably. To name things in a stable way, we do a depth-first-search of the bindings, starting from the exports sorted by name. This way, as long as the bindings themselves are deterministic (they sometimes aren't!), the order in which they are presented to the tidying phase does not affect the names we assign.  simonpj committed Mar 20, 2002 249 250 251 252 253 254  Step 2: Tidy the program ~~~~~~~~~~~~~~~~~~~~~~~~ Next we traverse the bindings top to bottom. For each *top-level* binder  simonpj committed Apr 28, 2005 255 256 257  1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal, reflecting the fact that from now on we regard it as a global, not local, Id  simonpj committed Mar 20, 2002 258 259 260 261 262  2. Give it a system-wide Unique. [Even non-exported things need system-wide Uniques because the byte-code generator builds a single Name->BCO symbol table.]  simonpj committed Oct 09, 2003 263  We use the NameCache kept in the HscEnv as the  simonpj committed Mar 20, 2002 264 265  source of such system-wide uniques.  simonpj committed Sep 13, 2002 266  For external Ids, use the original-name cache in the NameCache  simonpj committed Mar 20, 2002 267 268  to ensure that the unique assigned is the same as the Id had in any previous compilation run.  Simon Marlow committed Jul 20, 2009 269 270 271 272 273 274 275  3. Rename top-level Ids according to the names we chose in step 1. If it's an external Id, make it have a External Name, otherwise make it have an Internal Name. This is used by the code generator to decide whether to make the label externally visible 4. Give it its UTTERLY FINAL IdInfo; in ptic,  simonpj committed Mar 20, 2002 276 277 278 279 280 281 282 283 284 285 286 287  * its unfolding, if it should have one * its arity, computed from the number of visible lambdas * its CAF info, computed from what is free in its RHS Finally, substitute these new top-level binders consistently throughout, including in unfoldings. We also tidy binders in RHSs, so that they print nicely in interfaces. \begin{code}  simonpj committed Apr 28, 2005 288 tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)  simonpj@microsoft.com committed Jul 07, 2008 289 tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports,  chak@cse.unsw.edu.au. committed Oct 10, 2006 290 291  mg_types = type_env, mg_insts = insts, mg_fam_insts = fam_insts,  simonpj committed Apr 28, 2005 292 293  mg_binds = binds, mg_rules = imp_rules,  chak@cse.unsw.edu.au. committed May 07, 2007 294  mg_vect_info = vect_info,  Simon Marlow committed Apr 12, 2011 295  mg_anns = anns,  Simon Marlow committed Nov 06, 2007 296  mg_deps = deps,  andy@galois.com committed Oct 24, 2006 297  mg_foreign = foreign_stubs,  mnislaih committed Dec 10, 2006 298  mg_hpc_info = hpc_info,  Simon Marlow committed Apr 17, 2007 299  mg_modBreaks = modBreaks })  simonpj committed Apr 28, 2005 300   simonpj@microsoft.com committed Oct 29, 2009 301 302  = do { let { dflags = hsc_dflags hsc_env ; omit_prags = dopt Opt_OmitInterfacePragmas dflags  simonpj@microsoft.com committed Nov 19, 2009 303  ; expose_all = dopt Opt_ExposeAllUnfoldings dflags  Ian Lynagh committed Sep 18, 2010 304  ; th = xopt Opt_TemplateHaskell dflags  Simon Marlow committed Jul 20, 2009 305  }  simonpj@microsoft.com committed Dec 24, 2009 306  ; showPass dflags CoreTidy  Simon Marlow committed Jul 20, 2009 307   Simon Marlow committed Oct 14, 2009 308 309  ; let { implicit_binds = getImplicitBinds type_env }  Simon Marlow committed Jul 20, 2009 310  ; (unfold_env, tidy_occ_env)  simonpj@microsoft.com committed Nov 19, 2009 311 312  <- chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_rules  simonpj@microsoft.com committed Oct 29, 2009 313 314  ; let { ext_rules = findExternalRules omit_prags binds imp_rules unfold_env }  simonpj@microsoft.com committed Dec 07, 2009 315 316  -- Glom together imp_rules and rules currently attached to binders -- Then pick just the ones we need to expose  simonpj@microsoft.com committed Oct 29, 2009 317  -- See Note [Which rules to expose]  simonpj committed Mar 20, 2002 318   Simon Marlow committed Jul 20, 2009 319 320  ; let { (tidy_env, tidy_binds) = tidyTopBinds hsc_env unfold_env tidy_occ_env binds }  simonpj committed Mar 20, 2002 321   Simon Marlow committed Oct 11, 2006 322  ; let { export_set = availsToNameSet exports  simonpj@microsoft.com committed Nov 23, 2007 323 324  ; final_ids = [ id | id <- bindersOfBinds tidy_binds, isExternalName (idName id)]  simonpj@microsoft.com committed Jul 07, 2008 325 326  ; tidy_type_env = tidyTypeEnv omit_prags th export_set type_env final_ids  chak@cse.unsw.edu.au. committed Oct 10, 2006 327  ; tidy_insts = tidyInstances (lookup_dfun tidy_type_env) insts  simonpj committed Apr 28, 2005 328 329 330  -- A DFunId will have a binding in tidy_binds, and so -- will now be in final_env, replete with IdInfo -- Its name will be unchanged since it was born, but  chak@cse.unsw.edu.au. committed Oct 10, 2006 331 332  -- we want Global, IdInfo-rich (or not) DFunId in the -- tidy_insts  simonpj committed Apr 28, 2005 333 334 335  ; tidy_rules = tidyRules tidy_env ext_rules -- You might worry that the tidy_env contains IdInfo-rich stuff  chak@cse.unsw.edu.au. committed Oct 10, 2006 336 337  -- and indeed it does, but if omit_prags is on, ext_rules is -- empty  simonpj committed Apr 28, 2005 338   rl@cse.unsw.edu.au committed Oct 17, 2009 339 340  ; tidy_vect_info = tidyVectInfo tidy_env vect_info  simonpj@microsoft.com committed Dec 08, 2008 341 342 343  -- See Note [Injecting implicit bindings] ; all_tidy_binds = implicit_binds ++ tidy_binds  simonpj committed Apr 28, 2005 344  ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)  simonpj committed Apr 28, 2005 345  }  simonpj committed Mar 20, 2002 346   simonpj@microsoft.com committed Dec 24, 2009 347 348 349 350 351 352 353 354 355  ; endPass dflags CoreTidy all_tidy_binds tidy_rules -- If the endPass didn't print the rules, but ddump-rules is on, print now ; dumpIfSet (dopt Opt_D_dump_rules dflags && (not (dopt Opt_D_dump_simpl dflags))) CoreTidy (ptext (sLit "rules")) (pprRulesForUser tidy_rules)  simonpj@microsoft.com committed Mar 31, 2011 356 357 358 359 360 361 362 363 364  -- Print one-line size info ; let cs = coreBindsStats tidy_binds ; when (dopt Opt_D_dump_core_stats dflags) (printDump (ptext (sLit "Tidy size (terms,types,coercions)") <+> ppr (moduleName mod) <> colon <+> int (cs_tm cs) <+> int (cs_ty cs) <+> int (cs_co cs) ))  Simon Marlow committed Apr 12, 2011 365 366 367 368  ; return (CgGuts { cg_module = mod, cg_tycons = alg_tycons, cg_binds = all_tidy_binds, cg_foreign = foreign_stubs,  dterei committed Jun 17, 2011 369 370  cg_dep_pkgs = map fst $dep_pkgs deps, cg_hpc_info = hpc_info,  Simon Marlow committed Sep 05, 2007 371  cg_modBreaks = modBreaks },  simonpj committed Apr 28, 2005 372   chak@cse.unsw.edu.au. committed Oct 10, 2006 373 374 375  ModDetails { md_types = tidy_type_env, md_rules = tidy_rules, md_insts = tidy_insts,  simonpj@microsoft.com committed Nov 19, 2009 376 377  md_vect_info = tidy_vect_info, md_fam_insts = fam_insts,  mnislaih committed Dec 10, 2006 378  md_exports = exports,  rl@cse.unsw.edu.au committed Oct 17, 2009 379  md_anns = anns -- are already tidy  chak@cse.unsw.edu.au. committed May 07, 2007 380  })  simonpj committed Mar 20, 2002 381 382  }  Simon Marlow committed Nov 06, 2007 383 lookup_dfun :: TypeEnv -> Var -> Id  simonpj committed Apr 28, 2005 384 385 386 lookup_dfun type_env dfun_id = case lookupTypeEnv type_env (idName dfun_id) of Just (AnId dfun_id') -> dfun_id'  Simon Marlow committed Nov 06, 2007 387  _other -> pprPanic "lookup_dfun" (ppr dfun_id)  simonpj committed Mar 20, 2002 388   simonpj@microsoft.com committed Nov 23, 2007 389 --------------------------  simonpj@microsoft.com committed Jul 07, 2008 390 391 392 tidyTypeEnv :: Bool -- Compiling without -O, so omit prags -> Bool -- Template Haskell is on -> NameSet -> TypeEnv -> [Id] -> TypeEnv  simonpj committed Mar 20, 2002 393   simonmar committed Mar 03, 2003 394 -- The competed type environment is gotten from  simonpj committed Apr 28, 2005 395 -- Dropping any wired-in things, and then  simonmar committed Mar 03, 2003 396 397 398 399 -- a) keeping the types and classes -- b) removing all Ids, -- c) adding Ids with correct IdInfo, including unfoldings, -- gotten from the bindings  simonpj committed Oct 09, 2003 400 -- From (c) we keep only those Ids with External names;  simonmar committed Mar 03, 2003 401 402 403 404 405 -- the CoreTidy pass makes sure these are all and only -- the externally-accessible ones -- This truncates the type environment to include only the -- exported Ids and things needed from them, which saves space  Simon Marlow committed Oct 13, 2008 406 tidyTypeEnv omit_prags th exports type_env final_ids  simonpj@microsoft.com committed Jul 07, 2008 407  = let type_env1 = filterNameEnv keep_it type_env  simonpj committed Apr 28, 2005 408  type_env2 = extendTypeEnvWithIds type_env1 final_ids  simonpj@microsoft.com committed Jul 07, 2008 409  type_env3 | omit_prags = mapNameEnv (trimThing th exports) type_env2  simonpj committed Apr 28, 2005 410 411 412  | otherwise = type_env2 in type_env3  simonpj committed Mar 20, 2002 413  where  simonpj committed Apr 28, 2005 414  -- We keep GlobalIds, because they won't appear  simonpj committed Mar 20, 2002 415  -- in the bindings from which final_ids are derived!  simonpj committed Apr 28, 2005 416  -- (The bindings bind LocalIds.)  simonpj committed Apr 29, 2005 417  keep_it thing | isWiredInThing thing = False  simonpj committed Apr 28, 2005 418  keep_it (AnId id) = isGlobalId id -- Keep GlobalIds (e.g. class ops)  Simon Marlow committed Nov 06, 2007 419  keep_it _other = True -- Keep all TyCons, DataCons, and Classes  simonpj committed Apr 28, 2005 420   simonpj@microsoft.com committed Nov 23, 2007 421 422 423 424 425 -------------------------- isWiredInThing :: TyThing -> Bool isWiredInThing thing = isWiredInName (getName thing) --------------------------  simonpj@microsoft.com committed Jul 07, 2008 426 trimThing :: Bool -> NameSet -> TyThing -> TyThing  simonpj@microsoft.com committed Nov 23, 2007 427 -- Trim off inessentials, for boot files and no -O  simonpj@microsoft.com committed Jul 07, 2008 428 429 430 trimThing th exports (ATyCon tc) | not th && not (mustExposeTyCon exports tc) = ATyCon (makeTyConAbstract tc) -- Note [Trimming and Template Haskell]  simonpj@microsoft.com committed Nov 23, 2007 431   simonpj@microsoft.com committed Jul 07, 2008 432 trimThing _th _exports (AnId id)  simonpj@microsoft.com committed Nov 23, 2007 433 434  | not (isImplicitId id) = AnId (id setIdInfo vanillaIdInfo)  simonpj committed Apr 28, 2005 435   simonpj@microsoft.com committed Jul 07, 2008 436 trimThing _th _exports other_thing  simonpj@microsoft.com committed Nov 23, 2007 437  = other_thing  simonpj committed Apr 28, 2005 438 439   simonpj@microsoft.com committed Jul 07, 2008 440 441 442 443 444 445 446 447 448 449 450 451 {- Note [Trimming and Template Haskell] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (Trac #2386) this module M(T, makeOne) where data T = Yay String makeOne = [| Yay "Yep" |] Notice that T is exported abstractly, but makeOne effectively exports it too! A module that splices in$(makeOne) will then look for a declartion of Yay, so it'd better be there. Hence, brutally but simply, we switch off type constructor trimming if TH is enabled in this module. -}  simonpj committed Apr 28, 2005 452 453 454 455 456 457 458 459 460 mustExposeTyCon :: NameSet -- Exports -> TyCon -- The tycon -> Bool -- Can its rep be hidden? -- We are compiling without -O, and thus trying to write as little as -- possible into the interface file. But we must expose the details of -- any data types whose constructors or fields are exported mustExposeTyCon exports tc | not (isAlgTyCon tc) -- Synonyms = True  simonpj committed Jul 26, 2005 461 462 463  | isEnumerationTyCon tc -- For an enumeration, exposing the constructors = True -- won't lead to the need for further exposure -- (This includes data types with no constructors.)  simonpj@microsoft.com committed Sep 13, 2010 464  | isFamilyTyCon tc -- Open type family  chak@cse.unsw.edu.au. committed Sep 20, 2006 465  = True  simonpj@microsoft.com committed Dec 21, 2007 466   simonpj committed Apr 28, 2005 467 468 469 470  | otherwise -- Newtype, datatype = any exported_con (tyConDataCons tc) -- Expose rep if any datacon or field is exported  simonpj@microsoft.com committed Dec 21, 2007 471  || (isNewTyCon tc && isFFITy (snd (newTyConRhs tc)))  simonpj committed Apr 28, 2005 472 473 474 475 476 477 478 479 480 481 482 483 484 485  -- Expose the rep for newtypes if the rep is an FFI type. -- For a very annoying reason. 'Foreign import' is meant to -- be able to look through newtypes transparently, but it -- can only do that if it can "see" the newtype representation where exported_con con = any (elemNameSet exports) (dataConName con : dataConFieldLabels con) tidyInstances :: (DFunId -> DFunId) -> [Instance] -> [Instance] tidyInstances tidy_dfun ispecs = map tidy ispecs where tidy ispec = setInstanceDFunId ispec $tidy_dfun (instanceDFunId ispec)  simonpj committed Mar 20, 2002 486 487 \end{code}  rl@cse.unsw.edu.au committed Oct 17, 2009 488 489 \begin{code} tidyVectInfo :: TidyEnv -> VectInfo -> VectInfo  490 491 492 493 494 495 496 497 498 499 tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars , vectInfoPADFun = pas , vectInfoIso = isos , vectInfoScalarVars = scalarVars }) = info { vectInfoVar = tidy_vars , vectInfoPADFun = tidy_pas , vectInfoIso = tidy_isos , vectInfoScalarVars = tidy_scalarVars }  rl@cse.unsw.edu.au committed Oct 17, 2009 500 501 502 503 504 505 506 507 508 509 510  where tidy_vars = mkVarEnv$ map tidy_var_mapping $varEnvElts vars tidy_pas = mapNameEnv tidy_snd_var pas tidy_isos = mapNameEnv tidy_snd_var isos tidy_var_mapping (from, to) = (from', (from', lookup_var to)) where from' = lookup_var from tidy_snd_var (x, var) = (x, lookup_var var)  511 512 513 514  tidy_scalarVars = mkVarSet$ map lookup_var $varSetElems scalarVars  rl@cse.unsw.edu.au committed Oct 17, 2009 515 516 517 518  lookup_var var = lookupWithDefaultVarEnv var_env var var \end{code}  simonpj committed Apr 28, 2005 519   simonpj@microsoft.com committed Dec 08, 2008 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 %************************************************************************ %* * Implicit bindings %* * %************************************************************************ Note [Injecting implicit bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We inject the implict bindings right at the end, in CoreTidy. Some of these bindings, notably record selectors, are not constructed in an optimised form. E.g. record selector for data T = MkT { x :: {-# UNPACK #-} !Int } Then the unfolding looks like x = \t. case t of MkT x1 -> let x = I# x1 in x This generates bad code unless it's first simplified a bit. That is why CoreUnfold.mkImplicitUnfolding uses simleExprOpt to do a bit of optimisation first. (Only matters when the selector is used curried; eg map x ys.) See Trac #2070.  simonpj@microsoft.com committed Oct 15, 2009 539 540 541 542 543 [Oct 09: in fact, record selectors are no longer implicit Ids at all, because we really do want to optimise them properly. They are treated much like any other Id. But doing "light" optimisation on an implicit Id still makes sense.]  simonpj@microsoft.com committed Dec 08, 2008 544 545 546 547 548 549 550 551 552 At one time I tried injecting the implicit bindings *early*, at the beginning of SimplCore. But that gave rise to real difficulty, becuase GlobalIds are supposed to have *fixed* IdInfo, but the simplifier and other core-to-core passes mess with IdInfo all the time. The straw that broke the camels back was when a class selector got the wrong arity -- ie the simplifier gave it arity 2, whereas importing modules were expecting it to have arity 1 (Trac #2844). It's much safer just to inject them right at the end, after tidying.  simonpj@microsoft.com committed Jan 30, 2009 553 Oh: two other reasons for injecting them late:  simonpj@microsoft.com committed Oct 15, 2009 554   simonpj@microsoft.com committed Jan 30, 2009 555 556 557 558 559 560  - If implicit Ids are already in the bindings when we start TidyPgm, we'd have to be careful not to treat them as external Ids (in the sense of findExternalIds); else the Ids mentioned in *their* RHSs will be treated as external and you get an interface file saying a18 = but nothing refererring to a18 (because the implicit Id is the  simonpj@microsoft.com committed Oct 15, 2009 561  one that does, and implicit Ids don't appear in interface files).  simonpj@microsoft.com committed Jan 30, 2009 562 563 564 565 566  - More seriously, the tidied type-envt will include the implicit Id replete with a18 in its unfolding; but we won't take account of a18 when computing a fingerprint for the class; result chaos.  simonpj@microsoft.com committed Oct 15, 2009 567 568 569 570 There is one sort of implicit binding that is injected still later, namely those for data constructor workers. Reason (I think): it's really just a code generation trick.... binding itself makes no sense. See CorePrep Note [Data constructor workers].  simonpj@microsoft.com committed Dec 08, 2008 571 572 573 574  \begin{code} getImplicitBinds :: TypeEnv -> [CoreBind] getImplicitBinds type_env  simonpj@microsoft.com committed Jan 02, 2009 575  = map get_defn (concatMap implicit_ids (typeEnvElts type_env))  simonpj@microsoft.com committed Dec 08, 2008 576  where  simonpj@microsoft.com committed Jan 02, 2009 577  implicit_ids (ATyCon tc) = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)  simonpj@microsoft.com committed Sep 13, 2010 578  implicit_ids (AClass cls) = classAllSelIds cls  simonpj@microsoft.com committed Jan 02, 2009 579  implicit_ids _ = []  simonpj@microsoft.com committed Dec 08, 2008 580 581  get_defn :: Id -> CoreBind  simonpj@microsoft.com committed Nov 19, 2009 582  get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id))  simonpj@microsoft.com committed Dec 08, 2008 583 584 585 \end{code}  simonpj committed Mar 20, 2002 586 587 588 589 590 591 %************************************************************************ %* * \subsection{Step 1: finding externals} %* * %************************************************************************  Simon Marlow committed Jul 20, 2009 592 593 Sete Note [choosing external names].  simonpj committed Mar 20, 2002 594 \begin{code}  Simon Marlow committed Jul 20, 2009 595 type UnfoldEnv = IdEnv (Name{-new name-}, Bool {-show unfolding-})  simonpj@microsoft.com committed Oct 29, 2009 596 597  -- Maps each top-level Id to its new Name (the Id is tidied in step 2) -- The Unique is unchanged. If the new Name is external, it will be  Simon Marlow committed Jul 23, 2009 598 599 600  -- visible in the interface file. -- -- Bool => expose unfolding or not.  Simon Marlow committed Jul 20, 2009 601 602 603  chooseExternalIds :: HscEnv -> Module  simonpj@microsoft.com committed Nov 19, 2009 604  -> Bool -> Bool  Simon Marlow committed Jul 20, 2009 605  -> [CoreBind]  Simon Marlow committed Oct 14, 2009 606  -> [CoreBind]  simonpj@microsoft.com committed Oct 29, 2009 607  -> [CoreRule]  Simon Marlow committed Jul 20, 2009 608  -> IO (UnfoldEnv, TidyOccEnv)  simonpj committed Mar 20, 2002 609  -- Step 1 from the notes above  simonpj committed Apr 28, 2005 610   simonpj@microsoft.com committed Nov 19, 2009 611 chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules  simonpj@microsoft.com committed Oct 29, 2009 612 613 614  = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env ; let internal_ids = filter (not . (elemVarEnv unfold_env1)) binders ; tidy_internal internal_ids unfold_env1 occ_env1 }  Simon Marlow committed Jul 20, 2009 615 616 617  where nc_var = hsc_NC hsc_env  simonpj@microsoft.com committed Oct 29, 2009 618 619  -- init_ext_ids is the intial list of Ids that should be -- externalised. It serves as the starting point for finding a  Simon Marlow committed Jul 20, 2009 620 621  -- deterministic, tidy, renaming for all external Ids in this -- module.  simonpj@microsoft.com committed Oct 29, 2009 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636  -- -- It is sorted, so that it has adeterministic order (i.e. it's the -- same list every time this module is compiled), in contrast to the -- bindings, which are ordered non-deterministically. init_work_list = zip init_ext_ids init_ext_ids init_ext_ids = sortBy (compare on getOccName)$ filter is_external binders -- An Id should be external if either (a) it is exported or -- (b) it appears in the RHS of a local rule for an imported Id. -- See Note [Which rules to expose] is_external id = isExportedId id || id elemVarSet rule_rhs_vars rule_rhs_vars = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet imp_id_rules binders = bindersOfBinds binds  Simon Marlow committed Oct 14, 2009 637  implicit_binders = bindersOfBinds implicit_binds  simonpj@microsoft.com committed Oct 29, 2009 638  binder_set = mkVarSet binders  Simon Marlow committed Jul 20, 2009 639   Simon Marlow committed Oct 14, 2009 640  avoids = [getOccName name | bndr <- binders ++ implicit_binders,  Simon Marlow committed Jul 20, 2009 641  let name = idName bndr,  Simon Marlow committed Jul 28, 2009 642  isExternalName name ]  Simon Marlow committed Jul 20, 2009 643 644 645 646 647 648  -- In computing our "avoids" list, we must include -- all implicit Ids -- all things with global names (assigned once and for -- all by the renamer) -- since their names are "taken". -- The type environment is a convenient source of such things.  Simon Marlow committed Oct 14, 2009 649 650  -- In particular, the set of binders doesn't include -- implicit Ids at this stage.  simonpj committed Mar 20, 2002 651   Simon Marlow committed Jul 20, 2009 652 653 654 655 656 657 658 659 660 661 662  -- We also make sure to avoid any exported binders. Consider -- f{-u1-} = 1 -- Local decl -- ... -- f{-u2-} = 2 -- Exported decl -- -- The second exported decl must 'get' the name 'f', so we -- have to put 'f' in the avoids list before we get to the first -- decl. tidyTopId then does a no-op on exported binders. init_occ_env = initTidyOccEnv avoids  simonpj@microsoft.com committed Oct 29, 2009 663 664 665 666 667 668  search :: [(Id,Id)] -- The work-list: (external id, referrring id) -- Make a tidy, external Name for the external id, -- add it to the UnfoldEnv, and do the same for the -- transitive closure of Ids it refers to -- The referring id is used to generate a tidy --- name for the external id  Simon Marlow committed Jul 20, 2009 669 670 671 672 673 674  -> UnfoldEnv -- id -> (new Name, show_unfold) -> TidyOccEnv -- occ env for choosing new Names -> IO (UnfoldEnv, TidyOccEnv) search [] unfold_env occ_env = return (unfold_env, occ_env)  Simon Marlow committed Sep 29, 2009 675 676  search ((idocc,referrer) : rest) unfold_env occ_env | idocc elemVarEnv unfold_env = search rest unfold_env occ_env  Simon Marlow committed Jul 20, 2009 677  | otherwise = do  Simon Marlow committed Sep 29, 2009 678  (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc  Simon Marlow committed Jul 20, 2009 679 680 681  let (new_ids, show_unfold) | omit_prags = ([], False)  simonpj@microsoft.com committed Nov 19, 2009 682  | otherwise = addExternal expose_all refined_id  simonpj@microsoft.com committed Oct 29, 2009 683 684 685 686 687 688 689 690 691 692  -- 'idocc' is an *occurrence*, but we need to see the -- unfolding in the *definition*; so look up in binder_set refined_id = case lookupVarSet binder_set idocc of Just id -> id Nothing -> WARN( True, ppr idocc ) idocc unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold) referrer' | isExportedId refined_id = refined_id | otherwise = referrer  Simon Marlow committed Jul 20, 2009 693 694 695 696 697 698 699 700 701 702 703  -- search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env' tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv) tidy_internal [] unfold_env occ_env = return (unfold_env,occ_env) tidy_internal (id:ids) unfold_env occ_env = do (occ_env', name') <- tidyTopName mod nc_var Nothing occ_env id let unfold_env' = extendVarEnv unfold_env id (name',False) tidy_internal ids unfold_env' occ_env'  simonpj@microsoft.com committed Nov 19, 2009 704 705 addExternal :: Bool -> Id -> ([Id],Bool) addExternal expose_all id = (new_needed_ids, show_unfold)  Simon Marlow committed Jul 20, 2009 706 707  where new_needed_ids = unfold_ids ++  Simon Marlow committed Aug 03, 2009 708 709  filter (\id -> isLocalId id && not (id elemVarSet unfold_set))  simonpj@microsoft.com committed Oct 29, 2009 710  (varSetElems spec_ids) -- XXX non-det ordering  simonpj committed Mar 20, 2002 711 712  idinfo = idInfo id  simonpj@microsoft.com committed Dec 18, 2009 713  never_active = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))  simonpj@microsoft.com committed Oct 04, 2006 714  loop_breaker = isNonRuleLoopBreaker (occInfo idinfo)  simonpj@microsoft.com committed Nov 19, 2009 715  bottoming_fn = isBottomingSig (strictnessInfo idinfo orElse topSig)  simonpj committed Apr 28, 2005 716  spec_ids = specInfoFreeVars (specInfo idinfo)  simonpj committed Mar 20, 2002 717 718 719 720  -- Stuff to do with the Id's unfolding -- We leave the unfolding there even if there is a worker -- In GHCI the unfolding is used by importers  simonpj@microsoft.com committed Oct 29, 2009 721 722 723 724 725  show_unfold = isJust mb_unfold_ids (unfold_set, unfold_ids) = mb_unfold_ids orElse (emptyVarSet, []) mb_unfold_ids :: Maybe (IdSet, [Id]) -- Nothing => don't unfold mb_unfold_ids = case unfoldingInfo idinfo of  simonpj@microsoft.com committed Dec 18, 2009 726  CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_guidance = guide }  simonpj@microsoft.com committed May 31, 2010 727 728  | show_unfolding src guide -> Just (unf_ext_ids src unf_rhs)  simonpj@microsoft.com committed Dec 13, 2010 729  DFunUnfolding _ _ ops -> Just (exprsFvsInOrder (dfunArgExprs ops))  simonpj@microsoft.com committed May 31, 2010 730  _ -> Nothing  simonpj@microsoft.com committed May 06, 2010 731 732 733 734 735 736 737  where unf_ext_ids (InlineWrapper v) _ = (unitVarSet v, [v]) unf_ext_ids _ unf_rhs = exprFvsInOrder unf_rhs -- For a wrapper, externalise the wrapper id rather than the -- fvs of the rhs. The two usually come down to the same thing -- but I've seen cases where we had a wrapper id $w but a -- rhs where$w had been inlined; see Trac #3922  simonpj@microsoft.com committed Dec 18, 2009 738 739 740 741 742  show_unfolding unf_source unf_guidance = expose_all -- 'expose_all' says to expose all -- unfoldings willy-nilly  simonpj@microsoft.com committed Sep 15, 2010 743  || isStableSource unf_source -- Always expose things whose  simonpj@microsoft.com committed Dec 18, 2009 744 745 746 747 748 749  -- source is an inline rule || not (bottoming_fn -- No need to inline bottom functions || never_active -- Or ones that say not to || loop_breaker -- Or that are loop breakers || neverUnfoldGuidance unf_guidance)  Simon Marlow committed Jul 20, 2009 750 751 752 753 754 755 756 757  -- We want a deterministic free-variable list. exprFreeVars gives us -- a VarSet, which is in a non-deterministic order when converted to a -- list. Hence, here we define a free-variable finder that returns -- the free variables in the order that they are encountered. -- -- Note [choosing external names]  simonpj@microsoft.com committed Oct 29, 2009 758 759 760 761 762 763 764 765 766 exprFvsInOrder :: CoreExpr -> (VarSet, [Id]) exprFvsInOrder e = run (dffvExpr e) exprsFvsInOrder :: [CoreExpr] -> (VarSet, [Id]) exprsFvsInOrder es = run (mapM_ dffvExpr es) run :: DFFV () -> (VarSet, [Id]) run (DFFV m) = case m emptyVarSet [] of (set,ids,_) -> (set,ids)  Simon Marlow committed Jul 20, 2009 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799  newtype DFFV a = DFFV (VarSet -> [Var] -> (VarSet,[Var],a)) instance Monad DFFV where return a = DFFV $\set ids -> (set, ids, a) (DFFV m) >>= k = DFFV$ \set ids -> case m set ids of (set',ids',a) -> case k a of DFFV f -> f set' ids' insert :: Var -> DFFV () insert v = DFFV $\ set ids -> case () of _ | v elemVarSet set -> (set,ids,()) | otherwise -> (extendVarSet set v, v:ids, ()) dffvExpr :: CoreExpr -> DFFV () dffvExpr e = go emptyVarSet e where go scope e = case e of Var v | isLocalId v && not (v elemVarSet scope) -> insert v App e1 e2 -> do go scope e1; go scope e2 Lam v e -> go (extendVarSet scope v) e Note _ e -> go scope e Cast e _ -> go scope e Let (NonRec x r) e -> do go scope r; go (extendVarSet scope x) e Let (Rec prs) e -> do let scope' = extendVarSetList scope (map fst prs) mapM_ (go scope') (map snd prs) go scope' e Case e b _ as -> do go scope e mapM_ (go_alt (extendVarSet scope b)) as _other -> return () go_alt scope (_,xs,r) = go (extendVarSetList scope xs) r  simonpj committed Mar 20, 2002 800 801 802 \end{code}  Simon Marlow committed Jul 20, 2009 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 -------------------------------------------------------------------- -- tidyTopName -- This is where we set names to local/global based on whether they really are -- externally visible (see comment at the top of this module). If the name -- was previously local, we have to give it a unique occurrence name if -- we intend to externalise it. \begin{code} tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv -> Id -> IO (TidyOccEnv, Name) tidyTopName mod nc_var maybe_ref occ_env id | global && internal = return (occ_env, localiseName name) | global && external = return (occ_env, name) -- Global names are assumed to have been allocated by the renamer, -- so they already have the "right" unique -- And it's a system-wide unique too -- Now we get to the real reason that all this is in the IO Monad: -- we have to update the name cache in a nice atomic fashion | local && internal = do { nc <- readIORef nc_var ; let (nc', new_local_name) = mk_new_local nc ; writeIORef nc_var nc' ; return (occ_env', new_local_name) } -- Even local, internal names must get a unique occurrence, because -- if we do -split-objs we externalise the name later, in the code generator -- -- Similarly, we must make sure it has a system-wide Unique, because -- the byte-code generator builds a system-wide Name->BCO symbol table | local && external = do { nc <- readIORef nc_var ; let (nc', new_external_name) = mk_new_external nc ; writeIORef nc_var nc' ; return (occ_env', new_external_name) } | otherwise = panic "tidyTopName" where name = idName id external = isJust maybe_ref global = isExternalName name local = not global internal = not external loc = nameSrcSpan name old_occ = nameOccName name new_occ | Just ref <- maybe_ref, ref /= id = mkOccName (occNameSpace old_occ)$  Simon Marlow committed Jul 28, 2009 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866  let ref_str = occNameString (getOccName ref) occ_str = occNameString old_occ in case occ_str of '$':'w':_ -> occ_str -- workers: the worker for a function already -- includes the occname for its parent, so there's -- no need to prepend the referrer. _other | isSystemName name -> ref_str | otherwise -> ref_str ++ '_' : occ_str -- If this name was system-generated, then don't bother -- to retain its OccName, just use the referrer. These -- system-generated names will become "f1", "f2", etc. for -- a referrer "f".  Simon Marlow committed Jul 20, 2009 867 868 869 870  | otherwise = old_occ (occ_env', occ') = tidyOccName occ_env new_occ  Ian Lynagh committed Oct 21, 2010 871  mk_new_local nc = (nc { nsUniqs = us }, mkInternalName uniq occ' loc)  Simon Marlow committed Jul 20, 2009 872  where  Ian Lynagh committed Oct 21, 2010 873  (uniq, us) = takeUniqFromSupply (nsUniqs nc)  Simon Marlow committed Jul 20, 2009 874 875 876 877 878 879 880 881 882 883  mk_new_external nc = allocateGlobalBinder nc mod occ' loc -- If we want to externalise a currently-local name, check -- whether we have already assigned a unique for it. -- If so, use it; if not, extend the table. -- All this is done by allcoateGlobalBinder. -- This is needed when *re*-compiling a module in GHCi; we must -- use the same name for externally-visible things as we did before. \end{code}  simonpj committed Apr 28, 2005 884 \begin{code}  simonpj@microsoft.com committed Oct 29, 2009 885 886 887 findExternalRules :: Bool -- Omit pragmas -> [CoreBind] -> [CoreRule] -- Local rules for imported fns  Simon Marlow committed Jul 20, 2009 888  -> UnfoldEnv -- Ids that are exported, so we need their rules  simonpj committed Apr 28, 2005 889 890  -> [CoreRule] -- The complete rules are gotten by combining  simonpj@microsoft.com committed Oct 29, 2009 891  -- a) local rules for imported Ids  simonpj committed Apr 28, 2005 892  -- b) rules embedded in the top-level Ids  simonpj@microsoft.com committed Oct 29, 2009 893 894 895 findExternalRules omit_prags binds imp_id_rules unfold_env | omit_prags = [] | otherwise = filterOut internal_rule (imp_id_rules ++ local_rules)  simonpj committed Apr 28, 2005 896 897 898  where local_rules = [ rule | id <- bindersOfBinds binds,  Simon Marlow committed Jul 20, 2009 899  external_id id,  simonpj committed Apr 28, 2005 900 901 902 903  rule <- idCoreRules id ] internal_rule rule  Simon Marlow committed Jul 20, 2009 904  = any (not . external_id) (varSetElems (ruleLhsFreeIds rule))  simonpj committed Apr 28, 2005 905 906 907 908  -- Don't export a rule whose LHS mentions a locally-defined -- Id that is completely internal (i.e. not visible to an -- importing module)  Simon Marlow committed Jul 20, 2009 909 910 911  external_id id | Just (name,_) <- lookupVarEnv unfold_env id = isExternalName name | otherwise = False  simonpj committed Apr 28, 2005 912 913 \end{code}  simonpj@microsoft.com committed Oct 29, 2009 914 915 916 917 918 919 920 921 Note [Which rules to expose] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ findExternalRules filters imp_rules to avoid binders that aren't externally visible; but the externally-visible binders are computed (by findExternalIds) assuming that all orphan rules are externalised (see init_ext_ids in function 'search'). So in fact we may export more than we need. (It's a sort of mutual recursion.)  simonpj committed Apr 28, 2005 922   simonpj committed Mar 20, 2002 923 924 925 926 927 928 929 930 931 %************************************************************************ %* * \subsection{Step 2: top-level tidying} %* * %************************************************************************ \begin{code} -- TopTidyEnv: when tidying we need to know  simonpj committed Oct 09, 2003 932 -- * nc_var: The NameCache, containing a unique supply and any pre-ordained Names.  simonpj committed Mar 20, 2002 933 934 935 936 937 938 939 940 941 942 943 944 -- These may have arisen because the -- renamer read in an interface file mentioning M.$wf, say, -- and assigned it unique r77. If, on this compilation, we've -- invented an Id whose name is $wf (but with a different unique) -- we want to rename it to have unique r77, so that we can do easy -- comparisons with stuff from the interface file -- -- * occ_env: The TidyOccEnv, which tells us which local occurrences -- are 'used' -- -- * subst_env: A Var->Var mapping that substitutes the new Var for the old  simonpj committed Apr 28, 2005 945 tidyTopBinds :: HscEnv  Simon Marlow committed Jul 20, 2009 946 947  -> UnfoldEnv -> TidyOccEnv  simonpj committed Apr 28, 2005 948  -> [CoreBind]  Simon Marlow committed Jul 20, 2009 949  -> (TidyEnv, [CoreBind])  simonpj committed Apr 28, 2005 950   Simon Marlow committed Jul 20, 2009 951 tidyTopBinds hsc_env unfold_env init_occ_env binds  simonpj committed Apr 28, 2005 952  = tidy init_env binds  simonpj committed Apr 28, 2005 953  where  Simon Marlow committed Jul 20, 2009 954  init_env = (init_occ_env, emptyVarEnv)  simonpj committed Apr 28, 2005 955   Simon Marlow committed Jul 25, 2006 956 957  this_pkg = thisPackage (hsc_dflags hsc_env)  Simon Marlow committed Jul 20, 2009 958 959 960 961 962  tidy env [] = (env, []) tidy env (b:bs) = let (env1, b') = tidyTopBind this_pkg unfold_env env b (env2, bs') = tidy env1 bs in (env2, b':bs')  simonpj committed Apr 28, 2005 963   simonpj committed Oct 09, 2003 964 ------------------------  Simon Marlow committed Jul 25, 2006 965 tidyTopBind :: PackageId  Simon Marlow committed Jul 20, 2009 966 967 968 969 970  -> UnfoldEnv -> TidyEnv -> CoreBind -> (TidyEnv, CoreBind)  Simon Marlow committed Jul 23, 2009 971 tidyTopBind this_pkg unfold_env (occ_env,subst1) (NonRec bndr rhs)  Simon Marlow committed Jul 20, 2009 972  = (tidy_env2, NonRec bndr' rhs')  simonpj committed Mar 20, 2002 973  where  Simon Marlow committed Jul 20, 2009 974 975 976 977  Just (name',show_unfold) = lookupVarEnv unfold_env bndr caf_info = hasCafRefs this_pkg subst1 (idArity bndr) rhs (bndr', rhs') = tidyTopPair show_unfold tidy_env2 caf_info name' (bndr, rhs) subst2 = extendVarEnv subst1 bndr bndr'  Simon Marlow committed Jul 23, 2009 978  tidy_env2 = (occ_env, subst2)  Simon Marlow committed Jul 20, 2009 979   Simon Marlow committed Jul 23, 2009 980 tidyTopBind this_pkg unfold_env (occ_env,subst1) (Rec prs)  Simon Marlow committed Jul 20, 2009 981  = (tidy_env2, Rec prs')  simonpj committed Mar 20, 2002 982  where  Simon Marlow committed Jul 20, 2009 983 984 985 986 987 988 989  prs' = [ tidyTopPair show_unfold tidy_env2 caf_info name' (id,rhs) | (id,rhs) <- prs, let (name',show_unfold) = expectJust "tidyTopBind"$ lookupVarEnv unfold_env id ] subst2 = extendVarEnvList subst1 (bndrs zip map fst prs')  Simon Marlow committed Jul 23, 2009 990  tidy_env2 = (occ_env, subst2)  Simon Marlow committed Jul 20, 2009 991   simonpj committed Oct 09, 2003 992  bndrs = map fst prs  simonpj committed Mar 20, 2002 993   simonmar committed Mar 03, 2003 994 995 996  -- the CafInfo for a recursive group says whether *any* rhs in -- the group may refer indirectly to a CAF (because then, they all do). caf_info  Simon Marlow committed Jul 25, 2006 997  | or [ mayHaveCafRefs (hasCafRefs this_pkg subst1 (idArity bndr) rhs)  simonmar committed Mar 21, 2003 998  | (bndr,rhs) <- prs ] = MayHaveCafRefs  simonpj committed Oct 09, 2003 999 1000 1001  | otherwise = NoCafRefs -----------------------------------------------------------  Simon Marlow committed Jul 20, 2009 1002 tidyTopPair :: Bool -- show unfolding  simonpj committed Oct 09, 2003 1003 1004 1005 1006 1007 1008  -> TidyEnv -- The TidyEnv is used to tidy the IdInfo -- It is knot-tied: don't look at it! -> CafInfo -> Name -- New name -> (Id, CoreExpr) -- Binder and RHS before tidying -> (Id, CoreExpr)  simonpj committed Mar 20, 2002 1009 1010 1011 1012 1013 1014  -- This function is the heart of Step 2 -- The rec_tidy_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  Simon Marlow committed Jul 20, 2009 1015 tidyTopPair show_unfold rhs_tidy_env caf_info name' (bndr, rhs)  simonpj@microsoft.com committed Dec 21, 2009 1016  = (bndr1, rhs1)  simonpj committed Mar 20, 2002 1017  where  simonpj@microsoft.com committed Dec 11, 2009 1018 1019 1020 1021  bndr1 = mkGlobalId details name' ty' idinfo' details = idDetails bndr -- Preserve the IdDetails ty' = tidyTopType (idType bndr) rhs1 = tidyExpr rhs_tidy_env rhs  simonpj@microsoft.com committed Dec 21, 2009 1022 1023  idinfo' = tidyTopIdInfo rhs_tidy_env name' rhs rhs1 (idInfo bndr) show_unfold caf_info  simonpj committed Mar 20, 2002 1024 1025 1026 1027 1028 1029 1030 1031  -- tidyTopIdInfo creates the final IdInfo for top-level -- binders. There are two delicate pieces: -- -- * Arity. After CoreTidy, this arity must not change any more. -- Indeed, CorePrep must eta expand where necessary to make -- the manifest arity equal to the claimed arity. --  simonmar committed Mar 03, 2003 1032 1033 -- * CAF info. This must also remain valid through to code generation. -- We add the info here so that it propagates to all  simonpj committed Mar 20, 2002 1034 1035 -- occurrences of the binders in RHSs, and hence to occurrences in -- unfoldings, which are inside Ids imported by GHCi. Ditto RULES.  simonmar committed Mar 03, 2003 1036 -- CoreToStg makes use of this when constructing SRTs.  simonpj@microsoft.com committed Dec 21, 2009 1037 1038 1039 tidyTopIdInfo :: TidyEnv -> Name -> CoreExpr -> CoreExpr -> IdInfo -> Bool -> CafInfo -> IdInfo tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info  simonpj committed Jul 29, 2002 1040 1041 1042 1043  | not is_external -- For internal Ids (not externally visible) = vanillaIdInfo -- we only need enough info for code generation -- Arity and strictness info are enough; -- c.f. CoreTidy.tidyLetBndr  simonpj@microsoft.com committed Dec 21, 2009 1044 1045 1046  setCafInfo caf_info setArityInfo arity setStrictnessInfo final_sig  simonpj committed Jul 29, 2002 1047 1048 1049  | otherwise -- Externally-visible Ids get the whole lot = vanillaIdInfo  simonmar committed Mar 03, 2003 1050  setCafInfo caf_info  simonpj committed Jul 29, 2002 1051  setArityInfo arity  simonpj@microsoft.com committed Dec 21, 2009 1052 1053 1054  setStrictnessInfo final_sig setOccInfo robust_occ_info setInlinePragInfo (inlinePragInfo idinfo)  simonpj committed Mar 20, 2002 1055 1056 1057  setUnfoldingInfo unfold_info -- NB: we throw away the Rules -- They have already been extracted by findExternalRules  simonpj@microsoft.com committed Nov 19, 2009 1058  where  simonpj@microsoft.com committed Dec 21, 2009 1059 1060 1061 1062  is_external = isExternalName name --------- OccInfo ------------ robust_occ_info = zapFragileOcc (occInfo idinfo)  simonpj@microsoft.com committed Nov 19, 2009 1063 1064  -- It's important to keep loop-breaker information -- when we are doing -fexpose-all-unfoldings  simonpj committed Mar 20, 2002 1065   simonpj@microsoft.com committed Dec 21, 2009 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081  --------- Strictness ------------ final_sig | Just sig <- strictnessInfo idinfo = WARN( _bottom_hidden sig, ppr name ) Just sig | Just (_, sig) <- mb_bot_str = Just sig | otherwise = Nothing -- If the cheap-and-cheerful bottom analyser can see that -- the RHS is bottom, it should jolly well be exposed _bottom_hidden id_sig = case mb_bot_str of Nothing -> False Just (arity, _) -> not (appIsBottom id_sig arity) mb_bot_str = exprBotStrictness_maybe orig_rhs --------- Unfolding ------------ unf_info = unfoldingInfo idinfo  simonpj@microsoft.com committed Oct 25, 2010 1082  unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs  simonpj@microsoft.com committed Dec 21, 2009 1083  | otherwise = noUnfolding  simonpj@microsoft.com committed Oct 25, 2010 1084 1085 1086 1087  unf_from_rhs = mkTopUnfolding is_bot tidy_rhs is_bot = case final_sig of Just sig -> isBottomingSig sig Nothing -> False  simonpj@microsoft.com committed Dec 21, 2009 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109  -- NB: do *not* expose the worker if show_unfold is off, -- because that means this thing is a loop breaker or -- marked NOINLINE or something like that -- This is important: if you expose the worker for a loop-breaker -- then you can make the simplifier go into an infinite loop, because -- in effect the unfolding is exposed. See Trac #1709 -- -- You might think that if show_unfold is False, then the thing should -- not be w/w'd in the first place. But a legitimate reason is this: -- the function returns bottom -- In this case, show_unfold will be false (we don't expose unfoldings -- for bottoming functions), but we might still have a worker/wrapper -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.lhs --------- Arity ------------ -- Usually the Id will have an accurate arity on it, because -- the simplifier has just run, but not always. -- One case I found was when the last thing the simplifier -- did was to let-bind a non-atomic argument and then float -- it to the top level. So it seems more robust just to -- fix it here. arity = exprArity orig_rhs  simonmar committed Mar 03, 2003 1110 \end{code}  simonmar committed Mar 21, 2003 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133  %************************************************************************ %* * \subsection{Figuring out CafInfo for an expression} %* * %************************************************************************ hasCafRefs decides whether a top-level closure can point into the dynamic heap. We mark such things as MayHaveCafRefs' because this information is used to decide whether a particular closure needs to be referenced in an SRT or not. There are two reasons for setting MayHaveCafRefs: a) The RHS is a CAF: a top-level updatable thunk. b) The RHS refers to something that MayHaveCafRefs Possible improvement: In an effort to keep the number of CAFs (and hence the size of the SRTs) down, we could also look at the expression and decide whether it requires a small bounded amount of heap, so we can ignore it as a CAF. In these cases however, we would need to use an additional CAF list to keep track of non-collectable CAFs. \begin{code}  Simon Marlow committed Jul 25, 2006 1134 1135 hasCafRefs :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo hasCafRefs this_pkg p arity expr  simonpj@microsoft.com committed Sep 22, 2010 1136  | is_caf || mentions_cafs = MayHaveCafRefs  simonmar committed Mar 21, 2003 1137 1138 1139  | otherwise = NoCafRefs where mentions_cafs = isFastTrue (cafRefs p expr)  simonpj@microsoft.com committed Sep 22, 2010 1140 1141  is_dynamic_name = isDllName this_pkg is_caf = not (arity > 0 || rhsIsStatic is_dynamic_name expr)  andy@galois.com committed Nov 29, 2006 1142   simonmar committed Mar 21, 2003 1143 1144 1145 1146  -- NB. we pass in the arity of the expression, which is expected -- to be calculated by exprArity. This is because exprArity -- knows how much eta expansion is going to be done by -- CorePrep later on, and we don't want to duplicate that  simonpj committed Jun 10, 2003 1147  -- knowledge in rhsIsStatic below.  simonmar committed Mar 21, 2003 1148   Simon Marlow committed Nov 06, 2007 1149 cafRefs :: VarEnv Id -> Expr a -> FastBool  simonmar committed Mar 21, 2003 1150 1151 1152 1153 1154 1155 1156 1157 1158 cafRefs p (Var id) -- imported Ids first: | not (isLocalId id) = fastBool (mayHaveCafRefs (idCafInfo id)) -- now Ids local to this module: | otherwise = case lookupVarEnv p id of Just id' -> fastBool (mayHaveCafRefs (idCafInfo id')) Nothing -> fastBool False  Simon Marlow committed Nov 06, 2007 1159 cafRefs _ (Lit _) = fastBool False  simonpj committed Dec 22, 2004 1160 cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a  Simon Marlow committed Nov 06, 2007 1161 cafRefs p (Lam _ e) = cafRefs p e  simonpj committed Dec 22, 2004 1162 cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e  Simon Marlow committed Nov 06, 2007 1163 1164 1165 1166 cafRefs p (Case e _bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts) cafRefs p (Note _n e) = cafRefs p e cafRefs p (Cast e _co) = cafRefs p e cafRefs _ (Type _) = fastBool False  1167 cafRefs _ (Coercion _) = fastBool False  simonmar committed Mar 21, 2003 1168   Simon Marlow committed Nov 06, 2007 1169 1170 cafRefss :: VarEnv Id -> [Expr a] -> FastBool cafRefss _ [] = fastBool False  simonmar committed Mar 21, 2003 1171 1172 cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es  Simon Marlow committed Nov 06, 2007 1173 fastOr :: FastBool -> (a -> FastBool) -> a -> FastBool  simonmar committed Mar 21, 2003 1174 1175 1176 -- hack for lazy-or over FastBool. fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x)) \end{code}`