\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
import Id
-import Class
import IdInfo
import InstEnv
import NewDemand
= 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
-- 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))
+-- 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}
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_con_ids (typeEnvTyCons type_env)
- ++ concatMap other_implicit_ids (typeEnvElts type_env))
- -- Put the constructor wrappers first, because
- -- other implicit bindings (notably the fromT functions arising
- -- from generics) use the constructor wrappers. At least that's
- -- what External Core likes
+ = map get_defn (concatMap implicit_ids (typeEnvElts type_env))
where
- implicit_con_ids tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)
-
- other_implicit_ids (ATyCon tc) = filter (not . isNaughtyRecordSelector) (tyConSelIds tc)
- -- The "naughty" ones are not real functions at all
- -- They are there just so we can get decent error messages
- -- See Note [Naughty record selectors] in MkId.lhs
- other_implicit_ids (AClass cl) = classSelIds cl
- other_implicit_ids _other = []
+ 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))
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