X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FTidyPgm.lhs;h=88a30596010a36629ff58fbb9dad68e052c0a929;hb=4d3e73d7b6e2277a13b5af65c69ed1ffe644abf8;hp=2a068d9fb39c8af3f038ca55a01a005929233121;hpb=b182353f31d9f7a31f504571600b06d9a6d0723d;p=ghc-hetmet.git diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 2a068d9..88a3059 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -29,7 +29,7 @@ import IdInfo import InstEnv import NewDemand import BasicTypes -import Name +import Name hiding (varName) import NameSet import IfaceEnv import NameEnv @@ -50,8 +50,9 @@ import Data.IORef ( IORef, readIORef, writeIORef ) \end{code} -Constructing the TypeEnv, Instances, Rules from which the ModIface is -constructed, and which goes on to subsequent modules in --make mode. +Constructing the TypeEnv, Instances, Rules, VectInfo from which the +ModIface is constructed, and which goes on to subsequent modules in +--make mode. Most of the interface file is obtained simply by serialising the TypeEnv. One important consequence is that if the *interface file* @@ -303,8 +304,10 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, ; th = dopt Opt_TemplateHaskell dflags } + ; let { implicit_binds = getImplicitBinds type_env } + ; (unfold_env, tidy_occ_env) - <- chooseExternalIds hsc_env type_env mod omit_prags binds + <- chooseExternalIds hsc_env mod omit_prags binds implicit_binds ; let { ext_rules | omit_prags = [] @@ -337,8 +340,9 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, -- and indeed it does, but if omit_prags is on, ext_rules is -- empty + ; tidy_vect_info = tidyVectInfo tidy_env vect_info + -- See Note [Injecting implicit bindings] - ; implicit_binds = getImplicitBinds type_env ; all_tidy_binds = implicit_binds ++ tidy_binds ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) @@ -363,10 +367,9 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, ModDetails { md_types = tidy_type_env, md_rules = tidy_rules, md_insts = tidy_insts, - md_fam_insts = fam_insts, + md_vect_info = tidy_vect_info, md_fam_insts = fam_insts, md_exports = exports, - md_anns = anns, -- are already tidy - md_vect_info = vect_info -- + md_anns = anns -- are already tidy }) } @@ -475,6 +478,29 @@ tidyInstances tidy_dfun ispecs tidy_dfun (instanceDFunId ispec) \end{code} +\begin{code} +tidyVectInfo :: TidyEnv -> VectInfo -> VectInfo +tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars + , vectInfoPADFun = pas + , vectInfoIso = isos }) + = info { vectInfoVar = tidy_vars + , vectInfoPADFun = tidy_pas + , vectInfoIso = tidy_isos } + 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) + + lookup_var var = lookupWithDefaultVarEnv var_env var var +\end{code} + %************************************************************************ %* * @@ -495,6 +521,11 @@ 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. +[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.] + 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 @@ -505,18 +536,23 @@ 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. Oh: two other reasons for injecting them late: + - 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 - one that does). + one that does, and implicit Ids don't appear in interface files). - 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. +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]. \begin{code} getImplicitBinds :: TypeEnv -> [CoreBind] @@ -549,14 +585,14 @@ type UnfoldEnv = IdEnv (Name{-new name-}, Bool {-show unfolding-}) -- Bool => expose unfolding or not. chooseExternalIds :: HscEnv - -> TypeEnv -> Module -> Bool -> [CoreBind] + -> [CoreBind] -> IO (UnfoldEnv, TidyOccEnv) -- Step 1 from the notes above -chooseExternalIds hsc_env type_env mod omit_prags binds +chooseExternalIds hsc_env mod omit_prags binds implicit_binds = do (unfold_env1,occ_env1) <- search (zip sorted_exports sorted_exports) emptyVarEnv init_occ_env @@ -577,19 +613,22 @@ chooseExternalIds hsc_env type_env mod omit_prags binds filter isExportedId binders binders = bindersOfBinds binds + implicit_binders = bindersOfBinds implicit_binds - bind_env :: IdEnv CoreExpr - bind_env = mkVarEnv (flattenBinds binds) + bind_env :: IdEnv (Id,CoreExpr) + bind_env = mkVarEnv (zip (map fst bs) bs) where bs = flattenBinds binds - avoids = [getOccName name | bndr <- typeEnvIds type_env, + avoids = [getOccName name | bndr <- binders ++ implicit_binders, let name = idName bndr, - isExternalName name] + isExternalName name ] -- 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. + -- In particular, the set of binders doesn't include + -- implicit Ids at this stage. -- We also make sure to avoid any exported binders. Consider -- f{-u1-} = 1 -- Local decl @@ -609,12 +648,18 @@ chooseExternalIds hsc_env type_env mod omit_prags binds search [] unfold_env occ_env = return (unfold_env, occ_env) - search ((id,referrer) : rest) unfold_env occ_env - | id `elemVarEnv` unfold_env = search rest unfold_env occ_env + search ((idocc,referrer) : rest) unfold_env occ_env + | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env | otherwise = do - (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env id + (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc let - rhs = expectJust "chooseExternalIds" $ lookupVarEnv bind_env id + (id, rhs) = expectJust (showSDoc (text "chooseExternalIds: " <> + ppr idocc)) $ + lookupVarEnv bind_env idocc + -- NB. idocc might be an *occurrence* of an Id, whereas we want + -- the Id from the binding site, because only the latter is + -- guaranteed to have the unfolding attached. This is why we + -- keep binding site Ids in the bind_env. (new_ids, show_unfold) | omit_prags = ([], False) | otherwise = addExternal id rhs @@ -636,7 +681,8 @@ addExternal :: Id -> CoreExpr -> ([Id],Bool) addExternal id rhs = (new_needed_ids, show_unfold) where new_needed_ids = unfold_ids ++ - filter (not . (`elemVarSet` unfold_set)) + filter (\id -> isLocalId id && + not (id `elemVarSet` unfold_set)) (varSetElems worker_ids ++ varSetElems spec_ids) -- XXX non-det ordering @@ -768,7 +814,21 @@ tidyTopName mod nc_var maybe_ref occ_env id new_occ | Just ref <- maybe_ref, ref /= id = mkOccName (occNameSpace old_occ) $ - occNameString (getOccName ref) ++ '_' : occNameString old_occ + 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". | otherwise = old_occ (occ_env', occ') = tidyOccName occ_env new_occ