\section{Tidying up Core}
\begin{code}
-module TidyPgm( mkBootModDetailsDs, mkBootModDetailsTc, tidyProgram ) where
+module TidyPgm( mkBootModDetailsDs, mkBootModDetailsTc,
+ tidyProgram, globaliseAndTidyId ) where
#include "HsVersions.h"
import PprCore
import CoreLint
import CoreUtils
+import CoreArity ( exprArity )
+import Class ( classSelIds )
import VarEnv
import VarSet
-import Var hiding( mkGlobalId )
+import Var
import Id
import IdInfo
import InstEnv
import NameSet
import IfaceEnv
import NameEnv
-import OccName
import TcType
import DataCon
import TyCon
import FastBool hiding ( fastOr )
import Data.List ( partition )
-import Data.Maybe ( isJust )
import Data.IORef ( IORef, readIORef, writeIORef )
\end{code}
= do { let dflags = hsc_dflags hsc_env
; showPass dflags "Tidy [hoot] type env"
- ; let { insts' = tidyInstances tidyExternalId insts
+ ; let { insts' = tidyInstances globaliseAndTidyId insts
; dfun_ids = map instanceDFunId insts'
; type_env1 = tidyBootTypeEnv (availsToNameSet exports) type_env
; type_env' = extendTypeEnvWithIds type_env1 dfun_ids
, md_insts = insts'
, md_fam_insts = fam_insts
, md_rules = []
+ , md_anns = []
, md_exports = exports
, md_vect_info = noVectInfo
})
-- 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.
- final_ids = [ tidyExternalId id
+ final_ids = [ globaliseAndTidyId id
| id <- typeEnvIds type_env
, isLocalId id
, keep_it id ]
keep_it id = isExportedId id || idName id `elemNameSet` exports
-tidyExternalId :: Id -> Id
+
+globaliseAndTidyId :: Id -> Id
-- Takes an LocalId with an External Name,
--- makes it into a GlobalId with VanillaIdInfo, and tidies its type
--- (NB: vanillaIdInfo makes a conservative assumption about Caf-hood.)
-tidyExternalId id
- = ASSERT2( isLocalId id && isExternalName (idName id), ppr id )
- mkVanillaGlobal (idName id) (tidyTopType (idType id)) vanillaIdInfo
+-- 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)
\end{code}
mg_rules = imp_rules,
mg_vect_info = vect_info,
mg_dir_imps = dir_imps,
+ mg_anns = anns,
mg_deps = deps,
mg_foreign = foreign_stubs,
mg_hpc_info = hpc_info,
-- and indeed it does, but if omit_prags is on, ext_rules is
-- empty
+ -- See Note [Injecting implicit bindings]
+ ; implicit_binds = getImplicitBinds type_env
+ ; all_tidy_binds = implicit_binds ++ tidy_binds
+
; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
}
- ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds
+ ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds
; dumpIfSet_core dflags Opt_D_dump_simpl
"Tidy Core Rules"
(pprRules tidy_rules)
; return (CgGuts { cg_module = mod,
cg_tycons = alg_tycons,
- cg_binds = tidy_binds,
+ cg_binds = all_tidy_binds,
cg_dir_imps = dir_imp_mods,
cg_foreign = foreign_stubs,
cg_dep_pkgs = dep_pkgs deps,
md_insts = tidy_insts,
md_fam_insts = fam_insts,
md_exports = exports,
- md_vect_info = vect_info -- is already tidy
+ md_anns = anns, -- are already tidy
+ md_vect_info = vect_info --
})
}
-- This truncates the type environment to include only the
-- exported Ids and things needed from them, which saves space
-tidyTypeEnv th omit_prags exports type_env final_ids
+tidyTypeEnv omit_prags th exports type_env final_ids
= let type_env1 = filterNameEnv keep_it type_env
type_env2 = extendTypeEnvWithIds type_env1 final_ids
type_env3 | omit_prags = mapNameEnv (trimThing th exports) type_env2
%************************************************************************
+%* *
+ 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.
+
+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.
+
+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 = <blah>
+ but nothing refererring to a18 (because the implicit Id is the
+ one that does).
+
+ - 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.
+
+
+\begin{code}
+getImplicitBinds :: TypeEnv -> [CoreBind]
+getImplicitBinds type_env
+ = map get_defn (concatMap implicit_ids (typeEnvElts type_env))
+ where
+ implicit_ids (ATyCon tc) = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)
+ implicit_ids (AClass cls) = classSelIds cls
+ implicit_ids _ = []
+
+ get_defn :: Id -> CoreBind
+ get_defn id = NonRec id (unfoldingTemplate (idUnfolding id))
+\end{code}
+
+
+%************************************************************************
%* *
\subsection{Step 1: finding externals}
%* *
spec_ids
idinfo = idInfo id
- dont_inline = isNeverActive (inlinePragInfo idinfo)
+ dont_inline = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))
loop_breaker = isNonRuleLoopBreaker (occInfo idinfo)
bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
spec_ids = specInfoFreeVars (specInfo idinfo)
= (bndr', rhs')
where
bndr' = mkGlobalId details name' ty' idinfo'
- -- Preserve the GlobalIdDetails of existing global-ids
- details = case globalIdDetails bndr of
- NotGlobalId -> VanillaGlobal
- old_details -> old_details
+ details = idDetails bndr -- Preserve the IdDetails
ty' = tidyTopType (idType bndr)
rhs' = tidyExpr rhs_tidy_env rhs
idinfo = idInfo bndr
projects / ghc-hetmet.git / blobdiff