diff options
| author | simonpj <unknown> | 2001-12-05 15:00:21 +0000 |
|---|---|---|
| committer | simonpj <unknown> | 2001-12-05 15:00:21 +0000 |
| commit | b6fc61047ea6400e871a2ecca90738c56db19b97 (patch) | |
| tree | 7c1a3152e25a77f4d8401bc23afef8e3ae2fdb4f | |
| parent | 966c5772f3bfcb4bbf4e9e2aaa87def132811134 (diff) | |
| download | haskell-b6fc61047ea6400e871a2ecca90738c56db19b97.tar.gz | |
[project @ 2001-12-05 15:00:21 by simonpj]
Preserve IdInfo for strict binders
| -rw-r--r-- | ghc/compiler/simplCore/Simplify.lhs | 21 |
1 files changed, 13 insertions, 8 deletions
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index a318c667aa..8f1b22f0cb 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -294,16 +294,22 @@ 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 + -- fragile occurrence info in the substitution simplLetBndr env bndr `thenSmpl` \ (env, bndr') -> - simplStrictArg AnRhs env rhs rhs_se (idType bndr') cont_ty $ \ env rhs1 -> + let + -- simplLetBndr doesn't deal with the IdInfo, so we must + -- do so here (c.f. simplLazyBind) + bndr'' = bndr' `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr) + env1 = modifyInScope env bndr'' bndr'' + in + simplStrictArg AnRhs env1 rhs rhs_se (idType bndr') cont_ty $ \ env rhs1 -> -- Now complete the binding and simplify the body - completeNonRecX env True {- strict -} bndr bndr' rhs1 thing_inside + completeNonRecX env True {- strict -} bndr bndr'' rhs1 thing_inside | otherwise -- Normal, lazy case = -- Don't use simplBinder because that doesn't keep - -- fragile occurrence in the substitution + -- fragile occurrence info in the substitution simplLetBndr env bndr `thenSmpl` \ (env, bndr') -> simplLazyBind env NotTopLevel NonRecursive bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) -> @@ -441,13 +447,12 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se -- -- 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' + bndr'' = bndr' `setIdInfo` simplIdInfo (getSubst rhs_se) (idInfo bndr) env1 = modifyInScope env bndr'' bndr'' rhs_env = setInScope rhs_se env1 + is_top_level = isTopLevel top_lvl ok_float_unlifted = not is_top_level && isNonRec is_rec - rhs_cont = mkStop bndr_ty' AnRhs + rhs_cont = mkStop (idType bndr') AnRhs in -- Simplify the RHS; note the mkStop, which tells -- the simplifier that this is the RHS of a let. |