[project @ 2001-10-19 14:22:11 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 13918ad..88e6348 100644 (file)
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -14,7 +14,7 @@ import CmdLineOpts    ( dopt, DynFlag(Opt_D_dump_inlinings),
 import SimplMonad
 import SimplUtils      ( mkCase, mkLam, newId,
                          simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr,
-                         simplTopBndrs, SimplCont(..), DupFlag(..), LetRhsFlag(..), 
+                         SimplCont(..), DupFlag(..), LetRhsFlag(..), 
                          mkStop, mkBoringStop,  pushContArgs,
                          contResultType, countArgs, contIsDupable, contIsRhsOrArg,
                          getContArgs, interestingCallContext, interestingArg, isStrictType
@@ -24,8 +24,7 @@ import VarEnv
 import Id              ( Id, idType, idInfo, idArity, isDataConId, 
                          idUnfolding, setIdUnfolding, isDeadBinder,
                          idNewDemandInfo, setIdInfo,
-                         setIdOccInfo, isLocalId,
-                         zapLamIdInfo, setOneShotLambda, 
+                         setIdOccInfo, zapLamIdInfo, setOneShotLambda, 
                        )
 import IdInfo          ( OccInfo(..), isLoopBreaker,
                          setArityInfo, 
@@ -38,9 +37,9 @@ import CoreSyn
 import PprCore         ( pprParendExpr, pprCoreExpr )
 import CoreUnfold      ( mkOtherCon, mkUnfolding, otherCons, callSiteInline )
 import CoreUtils       ( exprIsDupable, exprIsTrivial, needsCaseBinding,
-                         exprIsConApp_maybe, mkPiType, findAlt, findDefault,
+                         exprIsConApp_maybe, mkPiType, findAlt, 
                          exprType, coreAltsType, exprIsValue, 
-                         exprOkForSpeculation, exprArity, 
+                         exprOkForSpeculation, exprArity, findDefault,
                          mkCoerce, mkSCC, mkInlineMe, mkAltExpr
                        )
 import Rules           ( lookupRule )
@@ -54,7 +53,7 @@ import Subst          ( mkSubst, substTy, substExpr,
                        )
 import TysPrim         ( realWorldStatePrimTy )
 import PrelInfo                ( realWorldPrimId )
-import BasicTypes      ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
+import BasicTypes      ( TopLevelFlag(..), isTopLevel, 
                          RecFlag(..), isNonRec
                        )
 import OrdList
@@ -230,7 +229,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.
-    simplTopBndrs env (bindersOfBinds binds)   `thenSmpl` \ (env, bndrs') -> 
+    simplRecBndrs env (bindersOfBinds binds)   `thenSmpl` \ (env, bndrs') -> 
     simpl_binds env binds bndrs'               `thenSmpl` \ (floats, _) ->
     freeTick SimplifierDone                    `thenSmpl_`
     returnSmpl (floatBinds floats)
@@ -442,11 +441,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'
        env1              = modifyInScope env bndr'' bndr''
        rhs_env           = setInScope rhs_se env1
-       ok_float_unlifted = isNotTopLevel top_lvl && isNonRec is_rec
+       ok_float_unlifted = not is_top_level && isNonRec is_rec
        rhs_cont          = mkStop bndr_ty' AnRhs
     in
        -- Simplify the RHS; note the mkStop, which tells 
@@ -480,8 +480,9 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se
        --         y* = E; x = case (scc y) of {...}
        -- Either we must be careful not to float demanded non-values, or
        -- we must use exprIsValue for the test, which ensures that the
-       -- thing is non-strict.  I think.  The WARN below tests for this
-    else if exprIsTrivial rhs2 || exprIsValue rhs2 then
+       -- thing is non-strict.  I think.  The WARN below tests for this.
+    else if is_top_level || exprIsTrivial rhs2 || exprIsValue rhs2 then
+
                -- There's a subtlety here.  There may be a binding (x* = e) in the
                -- floats, where the '*' means 'will be demanded'.  So is it safe
                -- to float it out?  Answer no, but it won't matter because
@@ -1238,6 +1239,12 @@ rebuildCase env scrut case_bndr alts cont
                        []    -> alts
                        other -> [alt | alt@(con,_,_) <- alts, 
                                        not (con `elem` impossible_cons)]
+
+       -- "handled_cons" are handled either by the context, 
+       -- or by a branch in this case expression
+       -- Don't add DEFAULT to the handled_cons!!
+       (alts_wo_default, _) = findDefault better_alts
+       handled_cons = impossible_cons ++ [con | (con,_,_) <- alts_wo_default]
     in
 
        -- Deal with the case binder, and prepare the continuation;
@@ -1249,11 +1256,11 @@ rebuildCase env scrut case_bndr alts cont
     simplCaseBinder env scrut case_bndr                `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) ->
 
        -- Deal with the case alternatives
-    simplAlts alt_env zap_occ_info impossible_cons
+    simplAlts alt_env zap_occ_info handled_cons
              case_bndr' better_alts cont'              `thenSmpl` \ alts' ->
 
        -- Put the case back together
-    mkCase scrut case_bndr' alts'                      `thenSmpl` \ case_expr ->
+    mkCase scrut handled_cons case_bndr' alts'         `thenSmpl` \ case_expr ->
 
        -- Notice that rebuildDone returns the in-scope set from env, not alt_env
        -- The case binder *not* scope over the whole returned case-expression
@@ -1358,20 +1365,16 @@ simplCaseBinder env other_scrut case_bndr
 simplAlts :: SimplEnv 
          -> (InId -> InId)             -- Occ-info zapper
          -> [AltCon]                   -- Alternatives the scrutinee can't be
+                                       -- in the default case
          -> OutId                      -- Case binder
          -> [InAlt] -> SimplCont
          -> SimplM [OutAlt]            -- Includes the continuation
 
-simplAlts env zap_occ_info impossible_cons case_bndr' alts cont'
+simplAlts env zap_occ_info handled_cons case_bndr' alts cont'
   = mapSmpl simpl_alt alts
   where
     inst_tys' = tyConAppArgs (idType case_bndr')
 
-       -- handled_cons is all the constructors that are dealt
-       -- with, either by being impossible, or by there being an alternative
-    (con_alts,_) = findDefault alts
-    handled_cons = impossible_cons ++ [con | (con,_,_) <- con_alts]
-
     simpl_alt (DEFAULT, _, rhs)
        = let
                -- In the default case we record the constructors that the