[project @ 2001-12-05 15:00:21 by simonpj]

[ghc-hetmet.git] / ghc / compiler / simplCore / Simplify.lhs

diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index b69e2b2..8f1b22f 100644 (file)
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -38,15 +38,15 @@ import PprCore              ( pprParendExpr, pprCoreExpr )
 import CoreUnfold      ( mkOtherCon, mkUnfolding, otherCons, callSiteInline )
 import CoreUtils       ( exprIsDupable, exprIsTrivial, needsCaseBinding,
                          exprIsConApp_maybe, mkPiTypes, findAlt, 
-                         exprType, coreAltsType, exprIsValue, 
+                         exprType, exprIsValue, 
                          exprOkForSpeculation, exprArity, findDefault,
                          mkCoerce, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg
                        )
 import Rules           ( lookupRule )
 import BasicTypes      ( isMarkedStrict )
 import CostCentre      ( currentCCS )
-import Type            ( isUnLiftedType, seqType, mkFunTy, tyConAppArgs, funArgTy,
-                         funResultTy, splitFunTy_maybe, splitFunTy, eqType
+import Type            ( isUnLiftedType, seqType, tyConAppArgs, funArgTy,
+                         splitFunTy_maybe, splitFunTy, eqType
                        )
 import Subst           ( mkSubst, substTy, substExpr,
                          isInScope, lookupIdSubst, simplIdInfo
@@ -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.
@@ -897,7 +902,8 @@ completeCall env var occ_info cont
                   pprTrace "Rule fired" (vcat [
                        text "Rule:" <+> ptext rule_name,
                        text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
-                       text "After: " <+> pprCoreExpr rule_rhs])
+                       text "After: " <+> pprCoreExpr rule_rhs,
+                       text "Cont:  " <+> ppr call_cont])
                 else
                        id)             $
                simplExprF env rule_rhs call_cont ;