#include "HsVersions.h"
import BasicTypes ( Arity )
-import VarEnv ( VarEnv, emptyVarEnv )
+import VarEnv ( VarEnv, emptyVarEnv, isEmptyVarEnv )
import UniqFM ( ufmToList )
import Outputable
\end{code}
isTopDmdType :: DmdType -> Bool
-- Only used on top-level types, hence the assert
-isTopDmdType (DmdType _ [] TopRes) = ASSERT( isEmptyVarEnv env) True
-isTopDmdType other = False
+isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True
+isTopDmdType other = False
isBotRes :: DmdResult -> Bool
isBotRes BotRes = True
idNewStrictness, setIdNewStrictness
)
import IdInfo {- loads of stuff -}
-import NewDemand ( isBottomingSig, topSig, isStrictDmd, isTopSig )
+import NewDemand ( isBottomingSig, topSig )
import BasicTypes ( isNeverActive )
import Name ( getOccName, nameOccName, globaliseName, setNameOcc,
localiseName, isGlobalName, setNameUnique
import UniqSupply ( splitUniqSupply, uniqFromSupply )
import List ( partition )
import Util ( mapAccumL )
-import Maybe ( isJust, fromJust, isNothing )
+import Maybe ( isJust )
import Outputable
\end{code}
--
-- Similarly for the demand info - on a let binder, this tells
-- CorePrep to turn the let into a case.
- final_id
- | totally_boring_info = new_id
- | otherwise = new_id `setIdNewDemandInfo` dmd_info
- `setIdNewStrictness` new_strictness
+ final_id = new_id `setIdNewDemandInfo` idNewDemandInfo id
+ `setIdNewStrictness` idNewStrictness id
- -- override the env we get back from tidyId with the new IdInfo
+ -- Override the env we get back from tidyId with the new IdInfo
-- so it gets propagated to the usage sites.
new_var_env = extendVarEnv var_env id final_id
- dmd_info = idNewDemandInfo id
- new_strictness = idNewStrictness id
- totally_boring_info = isTopSig new_strictness && not (isStrictDmd dmd_info)
-
tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)
tidyIdBndr env@(tidy_env, var_env) id
= -- Non-top-level variables
import BasicTypes ( Fixity(..), NewOrData(..), Activation(..),
Version, initialVersion, bumpVersion
)
+import NewDemand ( isTopSig )
import RnMonad
import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl )
import HscTypes ( VersionInfo(..), ModIface(..), ModDetails(..),
otherwise -> []
------------ Strictness --------------
+ -- No point in explicitly exporting TopSig
strict_hsinfo = case newStrictnessInfo id_info of
- Nothing -> []
- Just sig -> [HsStrictness sig]
+ Just sig | not (isTopSig sig) -> [HsStrictness sig]
+ other -> []
------------ Worker --------------
work_info = workerInfo id_info
\begin{code}
module SimplUtils (
- simplBinder, simplBinders, simplRecIds, simplLetId, simplLamBinders,
+ simplBinder, simplBinders, simplRecBndrs, simplLetBndr,
+ simplLamBndrs, simplTopBndrs,
newId, mkLam, mkCase,
-- The continuation type
findDefault, exprOkForSpeculation, exprIsValue
)
import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
-import Id ( Id, idType, idInfo,
+import Id ( Id, idType, idInfo, isLocalId,
mkSysLocal, hasNoBinding, isDeadBinder, idNewDemandInfo,
idUnfolding, idNewStrictness
)
returnSmpl (setSubst env subst', bndr')
-simplLamBinders :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
-simplLamBinders env bndrs
- = let
- (subst', bndrs') = mapAccumL Subst.simplLamBndr (getSubst env) bndrs
- in
- seqBndrs bndrs' `seq`
- returnSmpl (setSubst env subst', bndrs')
-
-simplRecIds :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
-simplRecIds env ids
- = let
- (subst', ids') = mapAccumL Subst.simplLetId (getSubst env) ids
- in
- seqBndrs ids' `seq`
- returnSmpl (setSubst env subst', ids')
-
-simplLetId :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
-simplLetId env id
+simplLetBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
+simplLetBndr env id
= let
(subst', id') = Subst.simplLetId (getSubst env) id
in
seqBndr id' `seq`
returnSmpl (setSubst env subst', id')
+simplTopBndrs, 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
+ in
+ seqBndrs bndrs' `seq`
+ returnSmpl (setSubst env subst', bndrs')
+
seqBndrs [] = ()
seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
)
import SimplMonad
import SimplUtils ( mkCase, mkLam, newId,
- simplBinder, simplLamBinders, simplBinders, simplRecIds, simplLetId,
- SimplCont(..), DupFlag(..), LetRhsFlag(..),
+ simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr,
+ simplTopBndrs, 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,
+ setIdOccInfo, isLocalId,
zapLamIdInfo, setOneShotLambda,
)
import IdInfo ( OccInfo(..), isLoopBreaker,
-- 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.
- simplRecIds env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') ->
+ simplTopBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') ->
simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) ->
freeTick SimplifierDone `thenSmpl_`
returnSmpl (floatBinds floats)
| isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr) -- A strict let
= -- Don't use simplBinder because that doesn't keep
-- fragile occurrence in the substitution
- simplLetId env bndr `thenSmpl` \ (env, bndr') ->
+ simplLetBndr env bndr `thenSmpl` \ (env, bndr') ->
simplStrictArg env AnRhs rhs rhs_se cont_ty $ \ env rhs1 ->
-- Now complete the binding and simplify the body
| otherwise -- Normal, lazy case
= -- Don't use simplBinder because that doesn't keep
-- fragile occurrence in the substitution
- simplLetId env bndr `thenSmpl` \ (env, bndr') ->
+ simplLetBndr env bndr `thenSmpl` \ (env, bndr') ->
simplLazyBind env NotTopLevel NonRecursive
bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) ->
addFloats env floats thing_inside
| otherwise = new_bndr_info `setUnfoldingInfo` unfolding
unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
- final_id = new_bndr `setIdInfo` info_w_unf
+ -- Don't fiddle with the IdInfo of a constructor
+ -- wrapper or other GlobalId.
+ final_id | isLocalId new_bndr = new_bndr `setIdInfo` info_w_unf
+ | otherwise = new_bndr
in
-- These seqs forces the Id, and hence its IdInfo,
-- and hence any inner substitutions
case_cont = Select NoDup bndr alts env (mkBoringStop (contResultType cont))
simplExprF env (Let (Rec pairs) body) cont
- = simplRecIds env (map fst pairs) `thenSmpl` \ (env, bndrs') ->
+ = simplRecBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') ->
-- NB: bndrs' don't have unfoldings or spec-envs
-- We add them as we go down, using simplPrags
-- Not enough args, so there are real lambdas left to put in the result
go env lam@(Lam _ _) cont
- = simplLamBinders env bndrs `thenSmpl` \ (env, bndrs') ->
+ = simplLamBndrs env bndrs `thenSmpl` \ (env, bndrs') ->
simplExpr env body `thenSmpl` \ body' ->
mkLam env bndrs' body' cont `thenSmpl` \ (floats, new_lam) ->
addFloats env floats $ \ env ->
projects / ghc-hetmet.git / commitdiff