Commit 25eca40d authored by simonpj's avatar simonpj
Browse files

[project @ 2001-10-04 08:35:24 by simonpj]

Heal the HEAD
parent a1b59a18
......@@ -21,7 +21,7 @@ module NewDemand(
#include "HsVersions.h"
import BasicTypes ( Arity )
import VarEnv ( VarEnv, emptyVarEnv )
import VarEnv ( VarEnv, emptyVarEnv, isEmptyVarEnv )
import UniqFM ( ufmToList )
import Outputable
\end{code}
......@@ -82,8 +82,8 @@ botDmdType = DmdType emptyDmdEnv [] BotRes
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
......
......@@ -28,7 +28,7 @@ import Id ( idType, idInfo, idName, isExportedId,
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
......@@ -51,7 +51,7 @@ import UniqFM ( mapUFM )
import UniqSupply ( splitUniqSupply, uniqFromSupply )
import List ( partition )
import Util ( mapAccumL )
import Maybe ( isJust, fromJust, isNothing )
import Maybe ( isJust )
import Outputable
\end{code}
......@@ -639,19 +639,13 @@ tidyLetBndr env (id,rhs)
--
-- 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
......
......@@ -20,6 +20,7 @@ import TysPrim ( alphaTyVars )
import BasicTypes ( Fixity(..), NewOrData(..), Activation(..),
Version, initialVersion, bumpVersion
)
import NewDemand ( isTopSig )
import RnMonad
import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl )
import HscTypes ( VersionInfo(..), ModIface(..), ModDetails(..),
......@@ -272,9 +273,10 @@ ifaceTyCls (AnId id) = iface_sig
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
......
......@@ -5,7 +5,8 @@
\begin{code}
module SimplUtils (
simplBinder, simplBinders, simplRecIds, simplLetId, simplLamBinders,
simplBinder, simplBinders, simplRecBndrs, simplLetBndr,
simplLamBndrs, simplTopBndrs,
newId, mkLam, mkCase,
-- The continuation type
......@@ -29,7 +30,7 @@ import CoreUtils ( cheapEqExpr, exprType,
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
)
......@@ -438,30 +439,41 @@ simplBinder env bndr
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
......
......@@ -13,8 +13,8 @@ import CmdLineOpts ( dopt, DynFlag(Opt_D_dump_inlinings),
)
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
......@@ -24,7 +24,7 @@ import VarEnv
import Id ( Id, idType, idInfo, idArity, isDataConId,
idUnfolding, setIdUnfolding, isDeadBinder,
idNewDemandInfo, setIdInfo,
setIdOccInfo,
setIdOccInfo, isLocalId,
zapLamIdInfo, setOneShotLambda,
)
import IdInfo ( OccInfo(..), isLoopBreaker,
......@@ -230,7 +230,7 @@ simplTopBinds env binds
-- 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)
......@@ -296,7 +296,7 @@ simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
| 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
......@@ -305,7 +305,7 @@ simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
| 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
......@@ -565,7 +565,10 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs
| 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
......@@ -669,7 +672,7 @@ simplExprF env (Case scrut bndr alts) cont
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
......@@ -721,7 +724,7 @@ simplLam env fun cont
-- 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 ->
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment