Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Shayne Fletcher
Glasgow Haskell Compiler
Commits
25eca40d
Commit
25eca40d
authored
Oct 04, 2001
by
simonpj
Browse files
[project @ 2001-10-04 08:35:24 by simonpj]
Heal the HEAD
parent
a1b59a18
Changes
5
Hide whitespace changes
Inline
Side-by-side
ghc/compiler/basicTypes/NewDemand.lhs
View file @
25eca40d
...
...
@@ -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
...
...
ghc/compiler/coreSyn/CoreTidy.lhs
View file @
25eca40d
...
...
@@ -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
--
o
verride the env we get back from tidyId with the new IdInfo
--
O
verride 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
...
...
ghc/compiler/main/MkIface.lhs
View file @
25eca40d
...
...
@@ -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
...
...
ghc/compiler/simplCore/SimplUtils.lhs
View file @
25eca40d
...
...
@@ -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
...
...
ghc/compiler/simplCore/Simplify.lhs
View file @
25eca40d
...
...
@@ -13,8 +13,8 @@ import CmdLineOpts ( dopt, DynFlag(Opt_D_dump_inlinings),
)
import SimplMonad
import SimplUtils ( mkCase, mkLam, newId,
simplBinder, simpl
Lam
Binders, simplB
i
nd
e
rs, simplRec
Id
s, simplLet
Id
,
SimplCont(..), DupFlag(..), LetRhsFlag(..),
simplBinder, simplBinders, simpl
Lam
Bndrs, simplRec
Bndr
s, simplLet
Bndr
,
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.
simpl
RecId
s env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') ->
simpl
TopBndr
s 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
simplLet
Id
env bndr `thenSmpl` \ (env, bndr') ->
simplLet
Bndr
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
simplLet
Id
env bndr
`thenSmpl` \ (env, bndr') ->
simplLet
Bndr
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
= simplRec
Id
s env (map fst pairs) `thenSmpl` \ (env, bndrs') ->
= simplRec
Bndr
s 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
= simplLamB
i
nd
e
rs 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 ->
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment