Commit 685e04e4 authored by simonpj's avatar simonpj

[project @ 2001-10-18 16:29:12 by simonpj]

----------------------------------------------
	The CoreTidy/CorePrep/CoreToStg saga continues
	[actually, this commit mostly completes the job]
	----------------------------------------------

			DO NOT MERGE!

* CorePrep injects implicit bindings, not the type checker,
  nor CgConTbls.   (This way, all the code generators see
  them, so no need to fiddle with the byte code generator.)

  As a result, all bindings in the module are for LocalIds,
  at least until CoreTidy.   This is a Big Win.

  Hence remove nasty isImplicitId test in update_bndr in
  SimplCore and DmdAnal

* hasNoBinding is no longer true of a dataConId (worker).
  There's an implicit curried binding for it.

* Remove yukky test in exprIsTrivial that did not regard
  a hasNoBinding Id as trivial; similarly in SimplUtils.tryEtaReduce

* In CoreTidy, get the names to avoid from the type env.
  That way it includes implicit bindings too.

* CoreTidy set the Arity of a top-level Id permanently;
  it's up to the rest of the compiler to respect it.
  Notably, CorePrep uses etaExpand to make the manifest arity
  match the claimed arity.

* As a result, nuke CgArity, so that CgInfo now contains only
  CafInfo.  The CafInfo is knot-tied as before.


Other things

* In Simplify.simplLazyBind, be a bit keener to float bindings
  out if it's a top-level binding.
parent 25e8bcad
......@@ -62,7 +62,6 @@ module Id (
idSpecialisation,
idCgInfo,
idCafInfo,
idCgArity,
idCprInfo,
idLBVarInfo,
idOccInfo,
......@@ -266,11 +265,12 @@ isDataConWrapId id = case globalIdDetails id of
DataConWrapId con -> True
other -> False
-- hasNoBinding returns True of an Id which may not have a
-- binding, even though it is defined in this module. Notably,
-- the constructors of a dictionary are in this situation.
-- hasNoBinding returns True of an Id which may not have a
-- binding, even though it is defined in this module.
-- Data constructor workers used to be things of this kind, but
-- they aren't any more. Instead, we inject a binding for
-- them at the CorePrep stage.
hasNoBinding id = case globalIdDetails id of
DataConId _ -> True
PrimOpId _ -> True
FCallId _ -> True
other -> False
......@@ -426,17 +426,6 @@ idCafInfo id = case cgInfo (idInfo id) of
info -> cgCafInfo info
#else
idCafInfo id = cgCafInfo (idCgInfo id)
#endif
---------------------------------
-- CG ARITY
idCgArity :: Id -> Arity
#ifdef DEBUG
idCgArity id = case cgInfo (idInfo id) of
NoCgInfo -> pprPanic "idCgArity" (ppr id)
info -> cgArity info
#else
idCgArity id = cgArity (idCgInfo id)
#endif
---------------------------------
......
......@@ -62,9 +62,8 @@ module IdInfo (
-- CG info
CgInfo(..), cgInfo, setCgInfo, pprCgInfo,
cgArity, cgCafInfo, vanillaCgInfo,
cgCafInfo, vanillaCgInfo,
CgInfoEnv, lookupCgInfo,
setCgArity,
-- CAF info
CafInfo(..), ppCafInfo, setCafInfo, mayHaveCafRefs,
......@@ -118,7 +117,6 @@ infixl 1 `setDemandInfo`,
`setOccInfo`,
`setCgInfo`,
`setCafInfo`,
`setCgArity`,
`setNewStrictnessInfo`,
`setNewDemandInfo`
-- infixl so you can say (id `set` a `set` b)
......@@ -341,7 +339,7 @@ vanillaIdInfo
}
noCafNoTyGenIdInfo = vanillaIdInfo `setTyGenInfo` TyGenNever
`setCgInfo` (CgInfo 0 NoCafRefs)
`setCgInfo` CgInfo NoCafRefs
-- Used for built-in type Ids in MkId.
-- Many built-in things have fixed types, so we shouldn't
-- run around generalising them
......@@ -539,33 +537,24 @@ but only as a thunk --- the information is only actually produced further
downstream, by the code generator.
\begin{code}
data CgInfo = CgInfo
!Arity -- Exact arity for calling purposes
!CafInfo
#ifdef DEBUG
#ifndef DEBUG
newtype CgInfo = CgInfo CafInfo -- We are back to only having CafRefs in CgInfo
noCgInfo = panic "NoCgInfo!"
#else
data CgInfo = CgInfo CafInfo
| NoCgInfo -- In debug mode we don't want a black hole here
-- See Id.idCgInfo
-- noCgInfo is used for local Ids, which shouldn't need any CgInfo
noCgInfo = NoCgInfo
#else
noCgInfo = panic "NoCgInfo!"
#endif
cgArity (CgInfo arity _) = arity
cgCafInfo (CgInfo _ caf_info) = caf_info
setCafInfo info caf_info =
case cgInfo info of { CgInfo arity _ ->
info `setCgInfo` CgInfo arity caf_info }
cgCafInfo (CgInfo caf_info) = caf_info
setCgArity info arity =
case cgInfo info of { CgInfo _ caf_info ->
info `setCgInfo` CgInfo arity caf_info }
setCafInfo info caf_info = info `setCgInfo` CgInfo caf_info
seqCg c = c `seq` () -- fields are strict anyhow
vanillaCgInfo = CgInfo 0 MayHaveCafRefs -- Definitely safe
vanillaCgInfo = CgInfo MayHaveCafRefs -- Definitely safe
-- CafInfo is used to build Static Reference Tables (see simplStg/SRT.lhs).
......@@ -583,7 +572,7 @@ mayHaveCafRefs _ = False
seqCaf c = c `seq` ()
pprCgInfo (CgInfo arity caf_info) = ppArity arity <+> ppCafInfo caf_info
pprCgInfo (CgInfo caf_info) = ppCafInfo caf_info
ppArity 0 = empty
ppArity n = hsep [ptext SLIT("__A"), int n]
......
......@@ -71,10 +71,10 @@ import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
)
import IdInfo ( IdInfo, noCafNoTyGenIdInfo,
setUnfoldingInfo,
setArityInfo, setSpecInfo, setCgInfo,
setArityInfo, setSpecInfo, setCgInfo, setCafInfo,
mkNewStrictnessInfo, setNewStrictnessInfo,
GlobalIdDetails(..), CafInfo(..), CprInfo(..),
CgInfo(..), setCgArity
CgInfo
)
import NewDemand ( mkStrictSig, strictSigResInfo, DmdResult(..),
mkTopDmdType, topDmd, evalDmd, Demand(..), Keepity(..) )
......@@ -145,7 +145,6 @@ mkDataConId work_name data_con
= mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info
where
info = noCafNoTyGenIdInfo
`setCgArity` arity
`setArityInfo` arity
`setNewStrictnessInfo` Just strict_sig
......@@ -234,7 +233,6 @@ mkDataConWrapId data_con
info = noCafNoTyGenIdInfo
`setUnfoldingInfo` mkTopUnfolding (mkInlineMe wrap_rhs)
`setCgArity` arity
-- The NoCaf-ness is set by noCafNoTyGenIdInfo
`setArityInfo` arity
-- It's important to specify the arity, so that partial
......@@ -433,7 +431,7 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
-- With all this unpackery it's not easy!
info = noCafNoTyGenIdInfo
`setCgInfo` CgInfo arity caf_info
`setCafInfo` caf_info
`setArityInfo` arity
`setUnfoldingInfo` mkTopUnfolding rhs_w_str
`setNewStrictnessInfo` Just strict_sig
......@@ -570,7 +568,6 @@ mkDictSelId name clas
tag = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` allFieldLabelTags) name
info = noCafNoTyGenIdInfo
`setCgArity` 1
`setArityInfo` 1
`setUnfoldingInfo` mkTopUnfolding rhs
`setNewStrictnessInfo` Just strict_sig
......@@ -630,7 +627,6 @@ mkPrimOpId prim_op
info = noCafNoTyGenIdInfo
`setSpecInfo` rules
`setCgArity` arity
`setArityInfo` arity
`setNewStrictnessInfo` Just (mkNewStrictnessInfo id arity strict_info NoCPRInfo)
-- Until we modify the primop generation code
......@@ -661,7 +657,6 @@ mkFCallId uniq fcall ty
name = mkFCallName uniq occ_str
info = noCafNoTyGenIdInfo
`setCgArity` arity
`setArityInfo` arity
`setNewStrictnessInfo` Just strict_sig
......
......@@ -9,22 +9,17 @@ module CgConTbls ( genStaticConBits ) where
#include "HsVersions.h"
import AbsCSyn
import StgSyn
import CgMonad
import AbsCUtils ( mkAbstractCs, mkAbsCStmts )
import CostCentre ( subsumedCCS )
import CgCon ( cgTopRhsCon )
import CgClosure ( cgTopRhsClosure )
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
import ClosureInfo ( layOutStaticConstr, layOutDynConstr, mkClosureLFInfo, ClosureInfo )
import DataCon ( DataCon, dataConName, dataConRepArgTys, dataConId, isNullaryDataCon )
import Id ( mkTemplateLocals )
import ClosureInfo ( layOutStaticConstr, layOutDynConstr, ClosureInfo )
import DataCon ( DataCon, dataConName, dataConRepArgTys, isNullaryDataCon )
import Name ( getOccName )
import OccName ( occNameUserString )
import TyCon ( tyConDataCons, isEnumerationTyCon, TyCon )
import Type ( typePrimRep )
import BasicTypes ( TopLevelFlag(..) )
import Outputable
\end{code}
......@@ -114,8 +109,7 @@ genConInfo comp_info data_con
= -- Order of things is to reduce forward references
mkAbstractCs [CSplitMarker,
closure_code,
static_code,
wrkr_code]
static_code]
where
(closure_info, body_code) = mkConCodeAndInfo data_con
......@@ -128,7 +122,6 @@ genConInfo comp_info data_con
profCtrC SLIT("TICK_ENT_CON") [CReg node] `thenC`
body_code)
wrkr_code = initC comp_info (cgWorker data_con `thenFC` \ _ -> returnFC ())
con_descr = occNameUserString (getOccName data_con)
-- Don't need any dynamic closure code for zero-arity constructors
......@@ -169,27 +162,3 @@ mkConCodeAndInfo con
in
(closure_info, body_code)
\end{code}
For a constructor C, make a binding
$wC = \x y -> $wC x y
i.e. a curried constructor that allocates. This means that we can treat
the worker for a constructor like any other function in the rest of the compiler.
\begin{code}
cgWorker data_con
| isNullaryDataCon data_con
= cgTopRhsCon work_id data_con []
| otherwise
= cgTopRhsClosure work_id
subsumedCCS noBinderInfo NoSRT
arg_ids rhs
lf_info
where
work_id = dataConId data_con
arg_ids = mkTemplateLocals (dataConRepArgTys data_con)
rhs = StgConApp data_con [StgVarArg id | id <- arg_ids]
lf_info = mkClosureLFInfo work_id TopLevel [{-no fvs-}] ReEntrant arg_ids
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: ClosureInfo.lhs,v 1.48 2001/09/26 15:11:50 simonpj Exp $
% $Id: ClosureInfo.lhs,v 1.49 2001/10/18 16:29:13 simonpj Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
......@@ -77,7 +77,7 @@ import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel,
import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling,
opt_Parallel, opt_DoTickyProfiling,
opt_SMP )
import Id ( Id, idType, idCgArity )
import Id ( Id, idType, idArity )
import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
isNullaryDataCon, dataConName
)
......@@ -249,7 +249,7 @@ mkLFLetNoEscape = LFLetNoEscape
mkLFImported :: Id -> LambdaFormInfo
mkLFImported id
= case idCgArity id of
= case idArity id of
n | n > 0 -> LFReEntrant (idType id) TopLevel n True -- n > 0
other -> LFImported -- Not sure of exact arity
\end{code}
......
......@@ -24,9 +24,11 @@ import VarSet
import VarEnv
import Id ( mkSysLocal, idType, idNewDemandInfo, idArity,
setIdType, isPrimOpId_maybe, isFCallId, isGlobalId,
hasNoBinding, idNewStrictness, setIdArity
hasNoBinding, idNewStrictness,
isDataConId_maybe, idUnfolding
)
import HscTypes ( ModDetails(..) )
import HscTypes ( ModDetails(..), implicitTyThingIds, typeEnvElts )
import Unique ( mkBuiltinUnique )
import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNotTopLevel,
RecFlag(..), isNonRec
)
......@@ -72,13 +74,19 @@ The goal of this pass is to prepare for code generation.
7. Give each dynamic CCall occurrence a fresh unique; this is
rather like the cloning step above.
8. Inject bindings for the "implicit" Ids:
* Constructor wrappers
* Constructor workers
* Record selectors
We want curried definitions for all of these in case they
aren't inlined by some caller.
This is all done modulo type applications and abstractions, so that
when type erasure is done for conversion to STG, we don't end up with
any trivial or useless bindings.
-- -----------------------------------------------------------------------------
-- Top level stuff
-- -----------------------------------------------------------------------------
......@@ -89,13 +97,18 @@ corePrepPgm dflags mod_details
= do showPass dflags "CorePrep"
us <- mkSplitUniqSupply 's'
let floats = initUs_ us (corePrepTopBinds emptyVarEnv (md_binds mod_details))
new_binds = foldrOL get [] floats
get (FloatLet b) bs = b:bs
get b bs = pprPanic "corePrepPgm" (ppr b)
let implicit_binds = mkImplicitBinds (md_types mod_details)
-- NB: we must feed mkImplicitBinds through corePrep too
-- so that they are suitably cloned and eta-expanded
endPass dflags "CorePrep" Opt_D_dump_prep new_binds
return (mod_details { md_binds = new_binds })
binds_out = initUs_ us (
corePrepTopBinds (md_binds mod_details) `thenUs` \ floats1 ->
corePrepTopBinds implicit_binds `thenUs` \ floats2 ->
returnUs (deFloatTop (floats1 `appOL` floats2))
)
endPass dflags "CorePrep" Opt_D_dump_prep binds_out
return (mod_details { md_binds = binds_out })
corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
corePrepExpr dflags expr
......@@ -105,7 +118,52 @@ corePrepExpr dflags expr
dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep"
(ppr new_expr)
return new_expr
\end{code}
-- -----------------------------------------------------------------------------
-- Implicit bindings
-- -----------------------------------------------------------------------------
Create any necessary "implicit" bindings (data constructors etc).
Namely:
* Constructor workers
* Constructor wrappers
* Data type record selectors
* Class op selectors
In the latter three cases, the Id contains the unfolding to use for
the binding. In the case of data con workers we create the rather
strange (non-recursive!) binding
$wC = \x y -> $wC x y
i.e. a curried constructor that allocates. This means that we can
treat the worker for a constructor like any other function in the rest
of the compiler. The point here is that CoreToStg will generate a
StgConApp for the RHS, rather than a call to the worker (which would
give a loop). As Lennart says: the ice is thin here, but it works.
Hmm. Should we create bindings for dictionary constructors? They are
always fully applied, and the bindings are just there to support
partial applications. But it's easier to let them through.
\begin{code}
mkImplicitBinds type_env
= [ NonRec id (get_unfolding id)
| id <- implicitTyThingIds (typeEnvElts type_env) ]
-- The etaExpand is so that the manifest arity of the
-- binding matches its claimed arity, which is an
-- invariant of top level bindings going into the code gen
where
tmpl_uniqs = map mkBuiltinUnique [1..]
get_unfolding id -- See notes above
| Just data_con <- isDataConId_maybe id = Var id -- The ice is thin here, but it works
| otherwise = unfoldingTemplate (idUnfolding id)
\end{code}
\begin{code}
-- ---------------------------------------------------------------------------
-- Dealing with bindings
-- ---------------------------------------------------------------------------
......@@ -120,6 +178,14 @@ instance Outputable FloatingBind where
type CloneEnv = IdEnv Id -- Clone local Ids
deFloatTop :: OrdList FloatingBind -> [CoreBind]
-- For top level only; we don't expect any FloatCases
deFloatTop floats
= foldrOL get [] floats
where
get (FloatLet b) bs = b:bs
get b bs = pprPanic "corePrepPgm" (ppr b)
allLazy :: TopLevelFlag -> RecFlag -> OrdList FloatingBind -> Bool
allLazy top_lvl is_rec floats
= foldrOL check True floats
......@@ -137,13 +203,14 @@ allLazy top_lvl is_rec floats
-- Bindings
-- ---------------------------------------------------------------------------
corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM (OrdList FloatingBind)
corePrepTopBinds env [] = returnUs nilOL
corePrepTopBinds env (bind : binds)
= corePrepTopBind env bind `thenUs` \ (env', bind') ->
corePrepTopBinds env' binds `thenUs` \ binds' ->
returnUs (bind' `appOL` binds')
corePrepTopBinds :: [CoreBind] -> UniqSM (OrdList FloatingBind)
corePrepTopBinds binds
= go emptyVarEnv binds
where
go env [] = returnUs nilOL
go env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') ->
go env' binds `thenUs` \ binds' ->
returnUs (bind' `appOL` binds')
-- NB: we do need to float out of top-level bindings
-- Consider x = length [True,False]
......@@ -159,6 +226,7 @@ corePrepTopBinds env (bind : binds)
-- x* = f a
-- And then x will actually end up case-bound
--------------------------------
corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
corePrepTopBind env (NonRec bndr rhs)
= cloneBndr env bndr `thenUs` \ (env', bndr') ->
......@@ -167,6 +235,7 @@ corePrepTopBind env (NonRec bndr rhs)
corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
--------------------------------
corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
-- This one is used for *local* bindings
corePrepBind env (NonRec bndr rhs)
......@@ -217,14 +286,12 @@ corePrepArg env arg dem
= corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
if exprIsTrivial arg'
then returnUs (floats, arg')
else newVar (exprType arg') (exprArity arg') `thenUs` \ v ->
mkLocalNonRec v dem floats arg' `thenUs` \ floats' ->
else newVar (exprType arg') `thenUs` \ v ->
mkLocalNonRec v dem floats arg' `thenUs` \ floats' ->
returnUs (floats', Var v)
-- version that doesn't consider an scc annotation to be trivial.
exprIsTrivial (Var v)
| hasNoBinding v = idArity v == 0
| otherwise = True
exprIsTrivial (Var v) = True
exprIsTrivial (Type _) = True
exprIsTrivial (Lit lit) = True
exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
......@@ -369,7 +436,7 @@ corePrepExprFloat env expr@(App _ _)
-- non-variable fun, better let-bind it
collect_args fun depth
= corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') ->
newVar ty (exprArity fun') `thenUs` \ fn_id ->
newVar ty `thenUs` \ fn_id ->
mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ floats ->
returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
where
......@@ -444,6 +511,10 @@ mkLocalNonRec bndr dem floats rhs
= floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs'))
where
bndr_ty = idType bndr
bndr_rep_ty = repType bndr_ty
mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
mkBinds binds body
| isNilOL binds = returnUs body
......@@ -484,7 +555,13 @@ etaExpandRhs bndr rhs
-- f = /\a -> \y -> let s = h 3 in g s y
--
getUniquesUs `thenUs` \ us ->
returnUs (etaExpand (idArity bndr) us rhs (idType bndr))
returnUs (etaExpand arity us rhs (idType bndr))
where
-- For a GlobalId, take the Arity from the Id.
-- It was set in CoreTidy and must not change
-- For all others, just expand at will
arity | isGlobalId bndr = idArity bndr
| otherwise = exprArity rhs
-- ---------------------------------------------------------------------------
-- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
......@@ -505,7 +582,7 @@ deLam expr
| otherwise
= case tryEta bndrs body of
Just no_lam_result -> returnUs no_lam_result
Nothing -> newVar (exprType expr) (exprArity expr) `thenUs` \ fn ->
Nothing -> newVar (exprType expr) `thenUs` \ fn ->
returnUs (Let (NonRec fn expr) (Var fn))
where
(bndrs,body) = collectBinders expr
......@@ -677,12 +754,9 @@ fiddleCCall id
-- Generating new binders
-- ---------------------------------------------------------------------------
newVar :: Type -> Arity -> UniqSM Id
-- We're creating a new let binder, and we must give
-- it the right arity for the benefit of the code generator.
newVar ty arity
newVar :: Type -> UniqSM Id
newVar ty
= seqType ty `seq`
getUniqueUs `thenUs` \ uniq ->
returnUs (mkSysLocal SLIT("sat") uniq ty
`setIdArity` arity)
returnUs (mkSysLocal SLIT("sat") uniq ty)
\end{code}
......@@ -21,11 +21,9 @@ import VarEnv
import VarSet
import Var ( Id, Var )
import Id ( idType, idInfo, idName, isExportedId,
idSpecialisation, idUnique, isDataConWrapId,
mkVanillaGlobal, mkGlobalId, isLocalId,
isDataConId, mkUserLocal, isGlobalId, globalIdDetails,
idNewDemandInfo, setIdNewDemandInfo, setIdCgInfo,
idNewStrictness, setIdNewStrictness
idSpecialisation, idUnique,
mkVanillaGlobal, isLocalId,
isImplicitId, mkUserLocal, setIdInfo
)
import IdInfo {- loads of stuff -}
import NewDemand ( isBottomingSig, topSig )
......@@ -40,7 +38,7 @@ import Module ( Module, moduleName )
import HscTypes ( PersistentCompilerState( pcs_PRS ),
PersistentRenamerState( prsOrig ),
NameSupply( nsNames, nsUniqs ),
TypeEnv, extendTypeEnvList,
TypeEnv, extendTypeEnvList, typeEnvIds,
ModDetails(..), TyThing(..)
)
import FiniteMap ( lookupFM, addToFM )
......@@ -151,11 +149,18 @@ tidyCorePgm dflags mod pcs cg_info_env
orig_ns = prsOrig prs
init_tidy_env = (orig_ns, initTidyOccEnv avoids, emptyVarEnv)
avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in,
isGlobalName (idName bndr)]
avoids = [getOccName name | bndr <- typeEnvIds env_tc,
let name = idName bndr,
isGlobalName 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.
; let ((orig_ns', occ_env, subst_env), tidy_binds)
= mapAccumL (tidyTopBind mod ext_ids)
= mapAccumL (tidyTopBind mod ext_ids cg_info_env)
init_tidy_env binds_in
; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules
......@@ -163,7 +168,7 @@ tidyCorePgm dflags mod pcs cg_info_env
; let prs' = prs { prsOrig = orig_ns' }
pcs' = pcs { pcs_PRS = prs' }
; let final_ids = [ addCgInfo cg_info_env id
; let final_ids = [ id
| bind <- tidy_binds
, id <- bindersOf bind
, isGlobalName (idName id)]
......@@ -190,16 +195,6 @@ tidyCorePgm dflags mod pcs cg_info_env
; return (pcs', tidy_details)
}
addCgInfo :: CgInfoEnv -> Id -> Id
-- Pin on the info that comes from the code generator
-- This doesn't make its way into the *bindings* that
-- go on to the code generator (that might give black holes etc)
-- Rather, it's pinned onto the Id in the type environment
-- that (a) generates the interface file
-- (b) in GHCi goes into subsequent compilations
addCgInfo cg_info_env id
= id `setIdCgInfo` lookupCgInfo cg_info_env (idName id)
tidyCoreExpr :: CoreExpr -> IO CoreExpr
tidyCoreExpr expr = return (tidyExpr emptyTidyEnv expr)
\end{code}
......@@ -235,9 +230,9 @@ mkFinalTypeEnv type_env final_ids
-- in interface files, because they are needed by importing modules when
-- using the compilation manager
-- We keep constructor workers,
-- because they won't appear in the bindings from which final_ids are derived!
keep_it (AnId id) = isDataConId id -- Remove all Ids except constructor workers
-- We keep implicit Ids, because they won't appear
-- in the bindings from which final_ids are derived!
keep_it (AnId id) = isImplicitId id -- Remove all Ids except implicit ones
keep_it other = True -- Keep all TyCons and Classes
\end{code}
......@@ -386,18 +381,20 @@ type TopTidyEnv = (NameSupply, TidyOccEnv, VarEnv Var)
tidyTopBind :: Module
-> IdEnv Bool -- Domain = Ids that should be external
-- True <=> their unfolding is external too
-> CgInfoEnv
-> TopTidyEnv -> CoreBind
-> (TopTidyEnv, CoreBind)
tidyTopBind mod ext_ids top_tidy_env (NonRec bndr rhs)
tidyTopBind mod ext_ids cg_info_env top_tidy_env (NonRec bndr rhs)
= ((orig,occ,subst) , NonRec bndr' rhs')
where
((orig,occ,subst), bndr')
= tidyTopBinder mod ext_ids rec_tidy_env rhs' top_tidy_env bndr
= tidyTopBinder mod ext_ids cg_info_env
rec_tidy_env rhs' top_tidy_env bndr
rec_tidy_env = (occ,subst)
rhs' = tidyExpr rec_tidy_env rhs
tidyTopBind mod ext_ids top_tidy_env (Rec prs)
tidyTopBind mod ext_ids cg_info_env top_tidy_env (Rec prs)
= (final_env, Rec prs')
where
(final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs
......@@ -407,12 +404,12 @@ tidyTopBind mod ext_ids top_tidy_env (Rec prs)
= ((orig,occ,subst), (bndr',rhs'))
where
((orig,occ,subst), bndr')
= tidyTopBinder mod ext_ids
= tidyTopBinder mod ext_ids cg_info_env
rec_tidy_env rhs' top_tidy_env bndr
rhs' = tidyExpr rec_tidy_env rhs
tidyTopBinder :: Module -> IdEnv Bool
tidyTopBinder :: Module -> IdEnv Bool -> CgInfoEnv
-> TidyEnv -> CoreExpr
-- The TidyEnv is used to tidy the IdInfo
-- The expr is the already-tided RHS
......@@ -420,34 +417,10 @@ tidyTopBinder :: Module -> IdEnv Bool
-> TopTidyEnv -> Id -> (TopTidyEnv, Id)
-- NB: tidyTopBinder doesn't affect the unique supply
tidyTopBinder mod ext_ids tidy_env rhs
tidyTopBinder mod ext_ids cg_info_env rec_tidy_env rhs
env@(ns2, occ_env2, subst_env2) id
| isDataConWrapId id -- Don't tidy constructor wrappers
= (env, id) -- The Id is stored in the TyCon, so it would be bad
-- if anything changed
-- HACK ALERT: we *do* tidy record selectors. Reason: they mention error
-- messages, which may be floated out:
-- x_field pt = case pt of
-- Rect x y -> y
-- Pol _ _ -> error "buggle wuggle"
-- The error message will be floated out so we'll get
-- lvl5 = error "buggle wuggle"
-- x_field pt = case pt of
-- Rect x y -> y
-- Pol _ _ -> lvl5
--
-- When this happens, it's vital that the Id exposed to importing modules
-- (by ghci) mentions lvl5 in its unfolding, not the un-tidied version.
--
-- What about the Id in the TyCon? It probably shouldn't be in the TyCon at
-- all, but in any case it will have the error message inline so it won't matter.
| otherwise
-- This function is the heart of Step 2
-- The second env is the one to use for the IdInfo
-- 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
......@@ -459,13 +432,12 @@ tidyTopBinder mod ext_ids tidy_env rhs
(orig_env', occ_env', name') = tidyTopName mod ns2 occ_env2
is_external
(idName id)
ty' = tidyTopType (idType id)