idSpecialisation,
idCgInfo,
idCafInfo,
- idCgArity,
idCprInfo,
idLBVarInfo,
idOccInfo,
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
#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
-
- ---------------------------------
-- CPR INFO
idCprInfo :: Id -> CprInfo
idCprInfo id = case cprInfo (idInfo id) of
-- CG info
CgInfo(..), cgInfo, setCgInfo, pprCgInfo,
- cgArity, cgCafInfo, vanillaCgInfo,
+ cgCafInfo, vanillaCgInfo,
CgInfoEnv, lookupCgInfo,
- setCgArity,
-- CAF info
CafInfo(..), ppCafInfo, setCafInfo, mayHaveCafRefs,
`setOccInfo`,
`setCgInfo`,
`setCafInfo`,
- `setCgArity`,
`setNewStrictnessInfo`,
`setNewDemandInfo`
-- infixl so you can say (id `set` a `set` b)
}
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
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).
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]
)
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(..) )
= mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info
where
info = noCafNoTyGenIdInfo
- `setCgArity` arity
`setArityInfo` arity
`setNewStrictnessInfo` Just strict_sig
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
-- 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
tag = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` allFieldLabelTags) name
info = noCafNoTyGenIdInfo
- `setCgArity` 1
`setArityInfo` 1
`setUnfoldingInfo` mkTopUnfolding rhs
`setNewStrictnessInfo` Just strict_sig
info = noCafNoTyGenIdInfo
`setSpecInfo` rules
- `setCgArity` arity
`setArityInfo` arity
`setNewStrictnessInfo` Just (mkNewStrictnessInfo id arity strict_info NoCPRInfo)
-- Until we modify the primop generation code
name = mkFCallName uniq occ_str
info = noCafNoTyGenIdInfo
- `setCgArity` arity
`setArityInfo` arity
`setNewStrictnessInfo` Just strict_sig
#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}
= -- 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
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
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}
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
)
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}
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
)
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
-- -----------------------------------------------------------------------------
= 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
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
-- ---------------------------------------------------------------------------
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
-- 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]
-- 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') ->
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)
= 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
-- 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
= 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
-- 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)
| 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
-- 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}
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 )
import HscTypes ( PersistentCompilerState( pcs_PRS ),
PersistentRenamerState( prsOrig ),
NameSupply( nsNames, nsUniqs ),
- TypeEnv, extendTypeEnvList,
+ TypeEnv, extendTypeEnvList, typeEnvIds,
ModDetails(..), TyThing(..)
)
import FiniteMap ( lookupFM, addToFM )
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
; 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)]
; 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}
-- 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}
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
= ((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
-> 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
(orig_env', occ_env', name') = tidyTopName mod ns2 occ_env2
is_external
(idName id)
- ty' = tidyTopType (idType id)
- idinfo' = tidyIdInfo tidy_env is_external unfold_info id
+ ty' = tidyTopType (idType id)
+ idinfo = tidyTopIdInfo rec_tidy_env is_external
+ (idInfo id) unfold_info
+ (lookupCgInfo cg_info_env name')
- id' | isGlobalId id = mkGlobalId (globalIdDetails id) name' ty' idinfo'
- | otherwise = mkVanillaGlobal name' ty' idinfo'
- -- The test ensures that record selectors (which must be tidied; see above)
- -- retain their details. If it's forgotten, importing modules get confused.
+ id' = mkVanillaGlobal name' ty' idinfo
subst_env' = extendVarEnv subst_env2 id id'
| otherwise = noUnfolding
-tidyIdInfo tidy_env is_external unfold_info id
+-- tidyTopIdInfo creates the final IdInfo for top-level
+-- binders. There are two delicate pieces:
+--
+-- * Arity. We assume that the simplifier has just run, so
+-- that there is a reasonable arity on each binder.
+-- After CoreTidy, this arity must not change any more.
+-- Indeed, CorePrep must eta expand where necessary to make
+-- the manifest arity equal to the claimed arity.
+--
+-- * CAF info, which comes from the CoreToStg pass via a knot.
+-- The CAF info will not be looked at by the downstream stuff:
+-- it *generates* it, and knot-ties it back. It will only be
+-- looked at by (a) MkIface when generating an interface file
+-- (b) In GHCi, importing modules
+-- Nevertheless, we add the info here so that it propagates to all
+-- occurrences of the binders in RHSs, and hence to occurrences in
+-- unfoldings, which are inside Ids imported by GHCi. Ditto RULES.
+--
+-- An alterative would be to do a second pass over the unfoldings
+-- of Ids, and rules, right at the top, but that would be a pain.
+
+tidyTopIdInfo tidy_env is_external idinfo unfold_info cg_info
| opt_OmitInterfacePragmas || not is_external
- -- No IdInfo if the Id isn't external, or if we don't have -O
- = vanillaIdInfo
- `setArityInfo` arityInfo core_idinfo
- `setNewStrictnessInfo` newStrictnessInfo core_idinfo
- -- Keep strictness and arity; both are used by CorePrep
+ -- Only basic info if the Id isn't external, or if we don't have -O
+ = basic_info
- | otherwise
- = vanillaIdInfo
- `setArityInfo` arityInfo core_idinfo
- `setNewStrictnessInfo` newStrictnessInfo core_idinfo
- `setInlinePragInfo` inlinePragInfo core_idinfo
+ | otherwise -- Add extra optimisation info
+ = basic_info
+ `setInlinePragInfo` inlinePragInfo idinfo
`setUnfoldingInfo` unfold_info
- `setWorkerInfo` tidyWorker tidy_env (workerInfo core_idinfo)
- -- NB: we throw away the Rules
- -- They have already been extracted by findExternalRules
+ `setWorkerInfo` tidyWorker tidy_env (workerInfo idinfo)
+ -- NB: we throw away the Rules
+ -- They have already been extracted by findExternalRules
+
where
- core_idinfo = idInfo id
-
+ -- baasic_info is attached to every top-level binder
+ basic_info = vanillaIdInfo
+ `setCgInfo` cg_info
+ `setArityInfo` arityInfo idinfo
+ `setNewStrictnessInfo` newStrictnessInfo idinfo
-- This is where we set names to local/global based on whether they really are
-- externally visible (see comment at the top of this module). If the name
Nothing -> (ns { nsUniqs = us2, nsNames = ns_names' }, occ_env', global_name)
-- If we want to globalise a currently-local name, check
-- whether we have already assigned a unique for it.
- -- If so, use it; if not, extend the table
+ -- If so, use it; if not, extend the table.
+ -- This is needed when *re*-compiling a module in GHCi; we want to
+ -- use the same name for externally-visible things as we did before.
where
global = isGlobalName name
--
-- Similarly for the demand info - on a let binder, this tells
-- CorePrep to turn the let into a case.
- final_id = new_id `setIdNewDemandInfo` idNewDemandInfo id
- `setIdNewStrictness` idNewStrictness id
+ --
+ -- Similarly arity info for eta expansion in CorePrep
+ final_id = new_id `setIdInfo` new_info
+ idinfo = idInfo id
+ new_info = vanillaIdInfo
+ `setArityInfo` arityInfo idinfo
+ `setNewStrictnessInfo` newStrictnessInfo idinfo
+ `setNewDemandInfo` newDemandInfo idinfo
-- Override the env we get back from tidyId with the new IdInfo
-- so it gets propagated to the usage sites.
-- The SrcLoc isn't important now,
-- though we could extract it from the Id
--
- -- All local Ids now have the same IdInfo, which should save some
- -- space.
+ -- All nested Ids now have the same IdInfo, namely none,
+ -- which should save some space.
(tidy_env', occ') = tidyOccName tidy_env (getOccName id)
ty' = tidyType env (idType id)
id' = mkUserLocal occ' (idUnique id) ty' noSrcLoc
exprIsValue,exprOkForSpeculation, exprIsBig,
exprIsConApp_maybe, exprIsAtom,
idAppIsBottom, idAppIsCheap,
- exprArity,
- -- Expr transformation
- etaExpand, exprArity, exprEtaExpandArity,
+
+ -- Arity and eta expansion
+ manifestArity, exprArity,
+ exprEtaExpandArity, etaExpand,
-- Size
coreBindsSize,
import PrimOp ( primOpOkForSpeculation, primOpIsCheap )
import Id ( Id, idType, globalIdDetails, idNewStrictness, idLBVarInfo,
mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
- isDataConId_maybe, mkSysLocal, hasNoBinding, isDataConId, isBottomingId
+ isDataConId_maybe, mkSysLocal, isDataConId, isBottomingId
)
import IdInfo ( LBVarInfo(..),
GlobalIdDetails(..),
@exprIsBottom@ is true of expressions that are guaranteed to diverge
+There used to be a gruesome test for (hasNoBinding v) in the
+Var case:
+ exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
+The idea here is that a constructor worker, like $wJust, is
+really short for (\x -> $wJust x), becuase $wJust has no binding.
+So it should be treated like a lambda. Ditto unsaturated primops.
+But now constructor workers are not "have-no-binding" Ids. And
+completely un-applied primops and foreign-call Ids are sufficiently
+rare that I plan to allow them to be duplicated and put up with
+saturating them.
+
\begin{code}
-exprIsTrivial (Var v)
- | hasNoBinding v = idArity v == 0
- -- WAS: | Just op <- isPrimOpId_maybe v = primOpIsDupable op
- -- The idea here is that a constructor worker, like $wJust, is
- -- really short for (\x -> $wJust x), becuase $wJust has no binding.
- -- So it should be treated like a lambda.
- -- Ditto unsaturated primops.
- -- This came up when dealing with eta expansion/reduction for
- -- x = $wJust
- -- Here we want to eta-expand. This looks like an optimisation,
- -- but it's important (albeit tiresome) that CoreSat doesn't increase
- -- anything's arity
- | otherwise = True
-exprIsTrivial (Type _) = True
-exprIsTrivial (Lit lit) = True
-exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
-exprIsTrivial (Note _ e) = exprIsTrivial e
-exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
-exprIsTrivial other = False
+exprIsTrivial (Var v) = True -- See notes above
+exprIsTrivial (Type _) = True
+exprIsTrivial (Lit lit) = True
+exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
+exprIsTrivial (Note _ e) = exprIsTrivial e
+exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
+exprIsTrivial other = False
exprIsAtom :: CoreExpr -> Bool
-- Used to decide whether to let-binding an STG argument
<- _scc_ "Core2Stg" stg2stg dflags this_mod stg_binds
let env_rhs :: CgInfoEnv
- env_rhs = mkNameEnv [ (idName bndr, CgInfo (stgRhsArity rhs) caf_info)
+ env_rhs = mkNameEnv [ (idName bndr, CgInfo caf_info)
| (bind,_) <- stg_binds2,
let caf_info
| stgBindHasCafRefs bind = MayHaveCafRefs
- | otherwise = NoCafRefs,
- (bndr,rhs) <- stgBindPairs bind ]
+ | otherwise = NoCafRefs,
+ bndr <- stgBinders bind ]
return (stg_binds2, cost_centre_info, env_rhs)
- where
- stgBindPairs (StgNonRec _ b r) = [(b,r)]
- stgBindPairs (StgRec _ prs) = prs
-
-
\end{code}
TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv,
extendTypeEnvList, extendTypeEnvWithIds,
- typeEnvClasses, typeEnvTyCons, typeEnvIds,
+ typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds,
ImportedModuleInfo, WhetherHasOrphans, ImportVersion, WhatsImported(..),
PersistentRenamerState(..), IsBootInterface, DeclsMap,
import CoreSyn ( CoreBind )
import Id ( Id )
import Class ( Class, classSelIds )
-import TyCon ( TyCon, tyConGenIds, tyConSelIds, tyConDataConsIfAvailable )
+import TyCon ( TyCon, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataConsIfAvailable )
import DataCon ( dataConId, dataConWrapId )
import BasicTypes ( Version, initialVersion, Fixity )
-- The ModDetails takes on several slightly different forms:
--
-- After typecheck + desugar
--- md_types Contains TyCons, Classes, and hasNoBinding Ids
+-- md_types Contains TyCons, Classes, and implicit Ids
-- md_insts All instances from this module (incl derived ones)
-- md_rules All rules from this module
-- md_binds Desugared bindings
ppr (ATyCon tc) = ptext SLIT("ATyCon") <+> ppr tc
ppr (AClass cl) = ptext SLIT("AClass") <+> ppr cl
-typeEnvClasses env = [cl | AClass cl <- nameEnvElts env]
-typeEnvTyCons env = [tc | ATyCon tc <- nameEnvElts env]
-typeEnvIds env = [id | AnId id <- nameEnvElts env]
+
+typeEnvElts :: TypeEnv -> [TyThing]
+typeEnvClasses :: TypeEnv -> [Class]
+typeEnvTyCons :: TypeEnv -> [TyCon]
+typeEnvIds :: TypeEnv -> [Id]
+
+typeEnvElts env = nameEnvElts env
+typeEnvClasses env = [cl | AClass cl <- typeEnvElts env]
+typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env]
+typeEnvIds env = [id | AnId id <- typeEnvElts env]
implicitTyThingIds :: [TyThing] -> [Id]
-- Add the implicit data cons and selectors etc
go (ATyCon tc) = tyConGenIds tc ++
tyConSelIds tc ++
[ n | dc <- tyConDataConsIfAvailable tc,
- n <- [dataConId dc, dataConWrapId dc] ]
+ n <- implicitConIds tc dc]
-- Synonyms return empty list of constructors and selectors
+
+ implicitConIds tc dc -- Newtypes have a constructor wrapper,
+ -- but no worker
+ | isNewTyCon tc = [dataConWrapId dc]
+ | otherwise = [dataConId dc, dataConWrapId dc]
\end{code}
TyThing(..), DFunId, Avails,
WhatsImported(..), GenAvailInfo(..),
ImportVersion, AvailInfo, Deprecations(..),
- lookupVersion,
+ lookupVersion, typeEnvIds
)
import CmdLineOpts
id_type = idType id
id_info = idInfo id
cg_info = idCgInfo id
- arity_info = cgArity cg_info
+ arity_info = arityInfo id_info
caf_info = cgCafInfo cg_info
hs_idinfo | opt_OmitInterfacePragmas = []
dump_types dfun_ids type_env
= text "TYPE SIGNATURES" $$ nest 4 (dump_sigs ids)
where
- ids = [id | AnId id <- nameEnvElts type_env, want_sig id]
+ ids = [id | id <- typeEnvIds type_env, want_sig id]
want_sig id | opt_PprStyle_Debug = True
| otherwise = isLocalId id &&
isGlobalName (idName id) &&
import CoreLint ( endPass )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
-import Id ( idName, setIdLocalExported, isImplicitId )
+import Id ( idName, setIdLocalExported )
import VarSet
import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
update_bndr bndr
- | isImplicitId bndr = bndr_with_rules
- -- Constructors, selectors; doesn't
- -- make sense to call setIdLocalExported
- -- They can have rules, though; e.g.
- -- class Foo a where { op :: a->a }
- -- {-# RULES op x = y #-}
| dont_discard bndr = setIdLocalExported bndr_with_rules
| otherwise = bndr_with_rules
where
\begin{code}
module SimplUtils (
- simplBinder, simplBinders, simplRecBndrs, simplLetBndr,
- simplLamBndrs, simplTopBndrs,
+ simplBinder, simplBinders, simplRecBndrs,
+ simplLetBndr, simplLamBndrs,
newId, mkLam, mkCase,
-- The continuation type
findDefault, exprOkForSpeculation, exprIsValue
)
import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
-import Id ( Id, idType, idInfo, isLocalId,
- mkSysLocal, hasNoBinding, isDeadBinder, idNewDemandInfo,
+import Id ( Id, idType, idInfo,
+ mkSysLocal, isDeadBinder, idNewDemandInfo,
idUnfolding, idNewStrictness
)
import NewDemand ( isStrictDmd, isBotRes, splitStrictSig )
seqBndr id' `seq`
returnSmpl (setSubst env subst', id')
-simplTopBndrs, simplLamBndrs, simplRecBndrs
+simplLamBndrs, simplRecBndrs
:: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
-simplTopBndrs = simplBndrs simplTopBinder
simplRecBndrs = simplBndrs Subst.simplLetId
simplLamBndrs = simplBndrs Subst.simplLamBndr
--- For top-level binders, don't use simplLetId for GlobalIds.
--- There are some of these, notably consructor wrappers, and we don't
--- want to clone them or fiddle with them at all.
--- Rather tiresomely, the specialiser may float a use of a constructor
--- wrapper to before its definition (which shouldn't really matter)
--- because it doesn't see the constructor wrapper as free in the binding
--- it is floating (because it's a GlobalId).
--- Then the simplifier brings all top level Ids into scope at the
--- beginning, and we don't want to lose the IdInfo on the constructor
--- wrappers. It would also be Bad to clone it!
-simplTopBinder subst bndr
- | isLocalId bndr = Subst.simplLetId subst bndr
- | otherwise = (subst, bndr)
-
simplBndrs simpl_bndr env bndrs
= let
(subst', bndrs') = mapAccumL simpl_bndr (getSubst env) bndrs
go [] (Var fun) | ok_fun fun = Just (Var fun) -- Success!
go _ _ = Nothing -- Failure!
- ok_fun fun = not (fun `elem` bndrs) && not (hasNoBinding fun)
- -- Note the awkward "hasNoBinding" test
- -- Details with exprIsTrivial
+ ok_fun fun = not (fun `elem` bndrs)
ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
\end{code}
import SimplMonad
import SimplUtils ( mkCase, mkLam, newId,
simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr,
- simplTopBndrs, SimplCont(..), DupFlag(..), LetRhsFlag(..),
+ SimplCont(..), DupFlag(..), LetRhsFlag(..),
mkStop, mkBoringStop, pushContArgs,
contResultType, countArgs, contIsDupable, contIsRhsOrArg,
getContArgs, interestingCallContext, interestingArg, isStrictType
import Id ( Id, idType, idInfo, idArity, isDataConId,
idUnfolding, setIdUnfolding, isDeadBinder,
idNewDemandInfo, setIdInfo,
- setIdOccInfo, isLocalId,
- zapLamIdInfo, setOneShotLambda,
+ setIdOccInfo, zapLamIdInfo, setOneShotLambda,
)
import IdInfo ( OccInfo(..), isLoopBreaker,
setArityInfo,
import PprCore ( pprParendExpr, pprCoreExpr )
import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons, callSiteInline )
import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding,
- exprIsConApp_maybe, mkPiType, findAlt, findDefault,
+ exprIsConApp_maybe, mkPiType, findAlt,
exprType, coreAltsType, exprIsValue,
- exprOkForSpeculation, exprArity,
+ exprOkForSpeculation, exprArity, findDefault,
mkCoerce, mkSCC, mkInlineMe, mkAltExpr
)
import Rules ( lookupRule )
)
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
-import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
+import BasicTypes ( TopLevelFlag(..), isTopLevel,
RecFlag(..), isNonRec
)
import OrdList
-- so that if a transformation rule has unexpectedly brought
-- anything into scope, then we don't get a complaint about that.
-- It's rather as if the top-level binders were imported.
- simplTopBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') ->
+ simplRecBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') ->
simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) ->
freeTick SimplifierDone `thenSmpl_`
returnSmpl (floatBinds floats)
--
-- NB: does no harm for non-recursive bindings
let
+ is_top_level = isTopLevel top_lvl
bndr_ty' = idType bndr'
bndr'' = simplIdInfo (getSubst rhs_se) (idInfo bndr) bndr'
env1 = modifyInScope env bndr'' bndr''
rhs_env = setInScope rhs_se env1
- ok_float_unlifted = isNotTopLevel top_lvl && isNonRec is_rec
+ ok_float_unlifted = not is_top_level && isNonRec is_rec
rhs_cont = mkStop bndr_ty' AnRhs
in
-- Simplify the RHS; note the mkStop, which tells
-- Either we must be careful not to float demanded non-values, or
-- we must use exprIsValue for the test, which ensures that the
-- thing is non-strict. I think. The WARN below tests for this.
- else if exprIsTrivial rhs2 || exprIsValue rhs2 then
+ else if is_top_level || exprIsTrivial rhs2 || exprIsValue rhs2 then
+
-- There's a subtlety here. There may be a binding (x* = e) in the
-- floats, where the '*' means 'will be demanded'. So is it safe
-- to float it out? Answer no, but it won't matter because
= let
caf_info = hasCafRefs env rhs
env' = extendVarEnv env id how_bound
- how_bound = LetBound (TopLet caf_info) (predictArity rhs)
+ how_bound = LetBound (TopLet caf_info) (manifestArity rhs)
(stg_rhs, fvs', lv_info) =
initLne env (
bind = StgNonRec (mkSRT lv_info) id stg_rhs
in
- ASSERT2(predictArity rhs == stgRhsArity stg_rhs, ppr id)
+ ASSERT2(isLocalId id || idArity id == manifestArity rhs, ppr id)
+ ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id)
ASSERT2(consistent caf_info bind, ppr id)
-- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
(env', fvs' `unionFVInfo` body_fvs, bind)
caf_info = hasCafRefss env1{-NB: not env'-} rhss
env' = extendVarEnvList env
- [ (b, LetBound (TopLet caf_info) (predictArity rhs))
+ [ (b, LetBound (TopLet caf_info) (manifestArity rhs))
| (b,rhs) <- pairs ]
(stg_rhss, fvs', lv_info)
bind = StgRec (mkSRT lv_info) (zip binders stg_rhss)
in
- ASSERT2(and [predictArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
+ ASSERT2(and [isLocalId bndr || manifestArity rhs == idArity bndr | (bndr,rhs) <- pairs], ppr binders)
+ ASSERT2(and [manifestArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
ASSERT2(consistent caf_info bind, ppr binders)
-- WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info)
(env', fvs' `unionFVInfo` body_fvs, bind)
binders = bindersOf bind
mk_binding bind_lv_info binder rhs
- = (binder, LetBound (NestedLet live_vars) (predictArity rhs))
+ = (binder, LetBound (NestedLet live_vars) (manifestArity rhs))
where
live_vars | let_no_escape = addLiveVar bind_lv_info binder
| otherwise = unitLiveVar binder
is_join_var j = occNameUserString (getOccName j) == "$j"
\end{code}
-%************************************************************************
-%* *
-\subsection{Arity prediction}
-%* *
-%************************************************************************
-
-To avoid yet another knot, we predict the arity of each function from
-its Core form, based on the number of visible top-level lambdas.
-It should be the same as the arity of the STG RHS!
-
-\begin{code}
-predictArity :: CoreExpr -> Int
-predictArity (Lam x e)
- | isTyVar x = predictArity e
- | otherwise = 1 + predictArity e
-predictArity (Note _ e)
- -- Ignore coercions. Top level sccs are removed by the final
- -- profiling pass, so we ignore those too.
- = predictArity e
-predictArity _ = 0
-\end{code}
-
%************************************************************************
%* *
import CoreUtils ( exprIsValue, exprArity )
import DataCon ( dataConTyCon )
import TyCon ( isProductTyCon, isRecursiveTyCon )
-import Id ( Id, idType, idDemandInfo, idArity,
- isDataConId, isImplicitId, isGlobalId,
+import Id ( Id, idType, idDemandInfo,
+ isDataConId, isGlobalId, idArity,
idNewStrictness, idNewStrictness_maybe, getNewStrictness, setIdNewStrictness,
idNewDemandInfo, setIdNewDemandInfo, newStrictnessFromOld )
import IdInfo ( newDemand )
-> CoreBind
-> (SigEnv, CoreBind)
dmdAnalTopBind sigs (NonRec id rhs)
- | isImplicitId id -- Don't touch the info on constructors, selectors etc
- = (sigs, NonRec id rhs) -- It's pre-computed in MkId.lhs
- | otherwise
= let
(sigs', _, (id', rhs')) = dmdAnalRhs TopLevel sigs (id, rhs)
in
-- Lots of the other code is there to make this
-- beautiful, compositional, application rule :-)
-dmdAnal sigs dmd (App fun arg) -- Non-type arguments
+dmdAnal sigs dmd e@(App fun arg) -- Non-type arguments
= let -- [Type arg handled above]
(fun_ty, fun') = dmdAnal sigs (Call dmd) fun
(arg_ty, arg') = dmdAnal sigs arg_dmd arg
splitDmdTy ty@(DmdType fv [] TopRes) = (Lazy, ty)
splitDmdTy ty@(DmdType fv [] BotRes) = (Bot, ty)
-- NB: Bot not Abs
-splitDmdTy (DmdType fv [] RetCPR) = panic "splitDmdTy"
+splitDmdTy ty@(DmdType fv [] RetCPR) = panic "splitDmdTy"
-- We should not be applying a product as a function!
\end{code}
get_changes_bind (NonRec id rhs) = get_changes_pr (id,rhs)
get_changes_pr (id,rhs)
- | isImplicitId id = empty -- We don't look inside these
- | otherwise = get_changes_var id $$ get_changes_expr rhs
+ = get_changes_var id $$ get_changes_expr rhs
get_changes_var var
| isId var = get_changes_str var $$ get_changes_dmd var
tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs)
tcPrag info (HsArity arity) =
- returnTc (info `setArityInfo` arity
- `setCgArity` arity)
+ returnTc (info `setArityInfo` arity)
tcPrag info (HsUnfold inline_prag expr)
= tcPragExpr unf_env name in_scope_vars expr `thenNF_Tc` \ maybe_expr' ->
import Id ( Id, idType, idUnfolding )
import Module ( Module, moduleName )
import Name ( Name )
-import NameEnv ( nameEnvElts, lookupNameEnv )
+import NameEnv ( lookupNameEnv )
import TyCon ( tyConGenInfo )
import BasicTypes ( EP(..), Fixity, RecFlag(..) )
import SrcLoc ( noSrcLoc )
import HscTypes ( PersistentCompilerState(..), HomeSymbolTable,
PackageTypeEnv, ModIface(..),
ModDetails(..), DFunId,
- TypeEnv, extendTypeEnvList,
- TyThing(..), implicitTyThingIds,
+ TypeEnv, extendTypeEnvList, typeEnvTyCons, typeEnvElts,
+ TyThing(..),
mkTypeEnv
)
\end{code}
zonkRules more_local_rules `thenNF_Tc` \ more_local_rules' ->
- let local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv final_env))
-
- -- Create any necessary "implicit" bindings (data constructors etc)
- -- 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.
- implicit_binds = andMonoBindList [ CoreMonoBind id (unfoldingTemplate unf)
- | id <- implicitTyThingIds local_things
- , let unf = idUnfolding id
- , hasUnfolding unf
- ]
+ let local_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv final_env))
local_type_env :: TypeEnv
local_type_env = mkTypeEnv local_things
new_pcs,
TcResults { tc_env = local_type_env,
tc_insts = map iDFunId local_insts,
- tc_binds = implicit_binds `AndMonoBinds` all_binds',
+ tc_binds = all_binds',
tc_fords = foi_decls ++ foe_decls',
tc_rules = all_local_rules
}
deriv_binds, local_rules) ->
ASSERT(nullBinds deriv_binds)
let
- local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv env))
+ local_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv env))
mod_details = ModDetails { md_types = mkTypeEnv local_things,
md_insts = map iDFunId local_inst_info,
tcGetEnv `thenTc` \ unf_env ->
let
- all_things = nameEnvElts (getTcGEnv unf_env)
+ all_things = typeEnvElts (getTcGEnv unf_env)
-- sometimes we're compiling in the context of a package module
-- (on the GHCi command line, for example). In this case, we
ppr_rules (tc_rules results),
if dopt Opt_Generics dflags then
- ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
+ ppr_gen_tycons (typeEnvTyCons (tc_env results))
else
empty
]
projects / ghc-hetmet.git / commitdiff