[project @ 2001-10-16 10:37:32 by simonpj]

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

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 21ebaa6..1dd3ea1 100644 (file)
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -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
                        )
@@ -40,7 +41,7 @@ import Type           ( Type, seqType,
                          splitRepFunTys, isStrictType
                        )
 import OccName         ( UserFS )
-import TyCon           ( tyConDataConsIfAvailable, isDataTyCon )
+import TyCon           ( tyConDataConsIfAvailable, isAlgTyCon, isNewTyCon )
 import DataCon         ( dataConRepArity, dataConSig, dataConArgTys )
 import Var             ( mkSysTyVar, tyVarKind )
 import Util            ( lengthExceeds, mapAccumL )
@@ -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
 
@@ -873,12 +885,18 @@ mkAlts scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
 --------------------------------------------------
 
 mkAlts scrut case_bndr alts
-  | Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr),
-    isDataTyCon tycon,                 -- It's a data type
-    (alts_no_deflt, Just rhs) <- findDefault alts,
-               -- There is a DEFAULT case
+  | (alts_no_deflt, Just rhs) <- findDefault alts,
+                       -- There is a DEFAULT case
+
+    Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr),
+    isAlgTyCon tycon,          -- It's a data type, tuple, or unboxed tuples.  
+    not (isNewTyCon tycon),    -- We can have a newtype, if we are just doing an eval:
+                               --      case x of { DEFAULT -> e }
+                               -- and we don't want to fill in a default for them!
+
     [missing_con] <- filter is_missing (tyConDataConsIfAvailable tycon)
-               -- There is just one missing constructor!
+                       -- There is just one missing constructor!
+
   = tick (FillInCaseDefault case_bndr) `thenSmpl_`
     getUniquesSmpl                     `thenSmpl` \ tv_uniqs ->
     getUniquesSmpl                     `thenSmpl` \ id_uniqs ->