\section{Tidying up Core}
\begin{code}
-module TidyPgm( mkBootModDetails, tidyProgram ) where
+module TidyPgm( mkBootModDetailsDs, mkBootModDetailsTc,
+ tidyProgram, globaliseAndTidyId ) where
#include "HsVersions.h"
+import TcRnTypes
+import FamInstEnv
import DynFlags
import CoreSyn
import CoreUnfold
import PprCore
import CoreLint
import CoreUtils
+import CoreArity ( exprArity )
+import Class ( classSelIds )
import VarEnv
import VarSet
import Var
import NameSet
import IfaceEnv
import NameEnv
-import OccName
import TcType
import DataCon
import TyCon
-import Class
import Module
import HscTypes
import Maybes
import ErrUtils
import UniqSupply
import Outputable
-import FastTypes hiding (fastOr)
+import FastBool hiding ( fastOr )
import Data.List ( partition )
-import Data.Maybe ( isJust )
import Data.IORef ( IORef, readIORef, writeIORef )
-
-_dummy :: FS.FastString
-_dummy = FSLIT("")
\end{code}
distinct OccNames in case of object-file splitting
\begin{code}
-mkBootModDetails :: HscEnv -> ModGuts -> IO ModDetails
-- 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
--
-- We don't look at the bindings at all -- there aren't any
-- for hs-boot files
-mkBootModDetails hsc_env (ModGuts { mg_exports = exports
- , mg_types = type_env
- , mg_insts = insts
- , mg_fam_insts = fam_insts
- })
+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
= do { let dflags = hsc_dflags hsc_env
; showPass dflags "Tidy [hoot] type env"
- ; let { insts' = tidyInstances tidyExternalId insts
- ; type_env1 = filterNameEnv (not . isWiredInThing) type_env
- ; type_env2 = mapNameEnv tidyBootThing type_env1
- ; type_env' = extendTypeEnvWithIds type_env2
- (map instanceDFunId 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
}
; return (ModDetails { md_types = type_env'
, md_insts = insts'
, md_fam_insts = fam_insts
, md_rules = []
+ , md_anns = []
, md_exports = exports
, md_vect_info = noVectInfo
})
}
where
-isWiredInThing :: TyThing -> Bool
-isWiredInThing thing = isWiredInName (getName thing)
+tidyBootTypeEnv :: NameSet -> TypeEnv -> TypeEnv
+tidyBootTypeEnv exports type_env
+ = tidyTypeEnv True False exports type_env final_ids
+ 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.
+ final_ids = [ globaliseAndTidyId id
+ | 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
+
-tidyBootThing :: TyThing -> TyThing
--- Just externalise the Ids; keep everything
-tidyBootThing (AnId id) | isLocalId id = AnId (tidyExternalId id)
-tidyBootThing thing = thing
-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}
\begin{code}
tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
-tidyProgram hsc_env
- (ModGuts { mg_module = mod, mg_exports = exports,
+tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports,
mg_types = type_env,
mg_insts = insts, mg_fam_insts = fam_insts,
mg_binds = binds,
mg_rules = imp_rules,
mg_vect_info = vect_info,
- mg_dir_imps = dir_imps, mg_deps = deps,
+ mg_dir_imps = dir_imps,
+ mg_anns = anns,
+ mg_deps = deps,
mg_foreign = foreign_stubs,
mg_hpc_info = hpc_info,
mg_modBreaks = modBreaks })
; showPass dflags "Tidy Core"
; let { omit_prags = dopt Opt_OmitInterfacePragmas dflags
+ ; th = dopt Opt_TemplateHaskell dflags
; ext_ids = findExternalIds omit_prags binds
; ext_rules
| omit_prags = []
binds
; let { export_set = availsToNameSet exports
- ; tidy_type_env = tidyTypeEnv omit_prags export_set type_env
- tidy_binds
+ ; final_ids = [ id | id <- bindersOfBinds tidy_binds,
+ isExternalName (idName id)]
+ ; tidy_type_env = tidyTypeEnv omit_prags th export_set
+ type_env final_ids
; tidy_insts = tidyInstances (lookup_dfun tidy_type_env) insts
-- A DFunId will have a binding in tidy_binds, and so
-- will now be in final_env, replete with IdInfo
-- and indeed it does, but if omit_prags is on, ext_rules is
-- empty
- ; implicit_binds = getImplicitBinds type_env
- ; all_tidy_binds = implicit_binds ++ tidy_binds
+ -- See Note [Injecting implicit bindings]
+ ; implicit_binds = getImplicitBinds type_env
+ ; all_tidy_binds = implicit_binds ++ tidy_binds
+
; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
}
"Tidy Core Rules"
(pprRules tidy_rules)
+ ; let dir_imp_mods = moduleEnvKeys dir_imps
+
; return (CgGuts { cg_module = mod,
cg_tycons = alg_tycons,
cg_binds = all_tidy_binds,
- cg_dir_imps = dir_imps,
+ cg_dir_imps = dir_imp_mods,
cg_foreign = foreign_stubs,
cg_dep_pkgs = dep_pkgs deps,
cg_hpc_info = hpc_info,
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 --
})
}
Just (AnId dfun_id') -> dfun_id'
_other -> pprPanic "lookup_dfun" (ppr dfun_id)
-tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [CoreBind] -> TypeEnv
+--------------------------
+tidyTypeEnv :: Bool -- Compiling without -O, so omit prags
+ -> Bool -- Template Haskell is on
+ -> NameSet -> TypeEnv -> [Id] -> TypeEnv
-- The competed type environment is gotten from
-- Dropping any wired-in things, and then
-- This truncates the type environment to include only the
-- exported Ids and things needed from them, which saves space
-tidyTypeEnv omit_prags exports type_env tidy_binds
- = let type_env1 = filterNameEnv keep_it type_env
+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 trim_thing type_env2
+ type_env3 | omit_prags = mapNameEnv (trimThing th exports) type_env2
| otherwise = type_env2
in
type_env3
where
- final_ids = [ id | id <- bindersOfBinds tidy_binds,
- isExternalName (idName id)]
-
-- We keep GlobalIds, because they won't appear
-- in the bindings from which final_ids are derived!
-- (The bindings bind LocalIds.)
keep_it (AnId id) = isGlobalId id -- Keep GlobalIds (e.g. class ops)
keep_it _other = True -- Keep all TyCons, DataCons, and Classes
- trim_thing thing
- = case thing of
- ATyCon tc | mustExposeTyCon exports tc -> thing
- | otherwise -> ATyCon (makeTyConAbstract tc)
+--------------------------
+isWiredInThing :: TyThing -> Bool
+isWiredInThing thing = isWiredInName (getName thing)
+
+--------------------------
+trimThing :: Bool -> NameSet -> TyThing -> TyThing
+-- Trim off inessentials, for boot files and no -O
+trimThing th exports (ATyCon tc)
+ | not th && not (mustExposeTyCon exports tc)
+ = ATyCon (makeTyConAbstract tc) -- Note [Trimming and Template Haskell]
+
+trimThing _th _exports (AnId id)
+ | not (isImplicitId id)
+ = AnId (id `setIdInfo` vanillaIdInfo)
- AnId id | isImplicitId id -> thing
- | otherwise -> AnId (id `setIdInfo` vanillaIdInfo)
+trimThing _th _exports other_thing
+ = other_thing
+
+
+{- 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. -}
- _other -> thing
mustExposeTyCon :: NameSet -- Exports
-> TyCon -- The tycon
| 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.)
- | isOpenTyCon tc -- open type family
+ | isOpenTyCon tc -- Open type family
= True
+
| otherwise -- Newtype, datatype
= any exported_con (tyConDataCons tc)
-- Expose rep if any datacon or field is exported
- || (isNewTyCon tc && isFFITy (snd (newTyConRep tc)))
+ || (isNewTyCon tc && isFFITy (snd (newTyConRhs tc)))
-- 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
where
tidy ispec = setInstanceDFunId ispec $
tidy_dfun (instanceDFunId ispec)
+\end{code}
+
+
+%************************************************************************
+%* *
+ 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_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 (tidyExpr emptyTidyEnv rhs)
- where
- rhs = unfoldingTemplate (idUnfolding id)
- -- Don't forget to tidy the body ! Otherwise you get silly things like
- -- \ tpl -> case tpl of tpl -> (tpl,tpl) -> tpl
+ get_defn id = NonRec id (unfoldingTemplate (idUnfolding id))
\end{code}
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)
-- in the IdInfo of one early in the group
tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs)
- | isGlobalId bndr -- Injected binding for record selector, etc
- = (bndr, tidyExpr rhs_tidy_env rhs)
- | otherwise
= (bndr', rhs')
where
- bndr' = mkVanillaGlobal name' ty' idinfo'
+ bndr' = mkGlobalId details name' ty' idinfo'
+ details = idDetails bndr -- Preserve the IdDetails
ty' = tidyTopType (idType bndr)
rhs' = tidyExpr rhs_tidy_env rhs
idinfo = idInfo bndr
= NoWorker
tidyWorker tidy_env show_unfold (HasWorker work_id wrap_arity)
| show_unfold = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
- | otherwise = WARN( True, ppr work_id ) NoWorker
+ | otherwise = NoWorker
-- 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
-- then you can make the simplifier go into an infinite loop, because
-- in effect the unfolding is exposed. See Trac #1709
--
- -- Mind you, it probably should not be w/w'd in the first place;
- -- hence the WARN
+ -- 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
\end{code}
%************************************************************************
projects / ghc-hetmet.git / blobdiff