[project @ 2001-09-14 15:44:13 by simonpj]

--------------------------
	Cleanup in DataCon
	--------------------------

	DO NOT merge with stable

The dataConRepStrictness call used to reuturn a [Demand],
but that's a bit misleading.  In particular, consider a  strict
constructor

	data Foo = MkFoo ![Int]

Then the wrapper MkFoo is strict, but the worker $wMkFoo is not.

	MkFoo x = case x of { DEFAULT -> $wMkFoo x }

Nevertheless, when we pattern-match on $wMkFoo we will surely
find an evaluated component to the data structure, and that is
what dataConRepStrictness reports, and that's how it is used
in Simplify.

Solution: make dataConRepStrictness return [StrictnessMark]
not [Demand]. A small matter really.

diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs
index b5a093e..077e138 100644 (file)
--- a/ghc/compiler/basicTypes/DataCon.lhs
+++ b/ghc/compiler/basicTypes/DataCon.lhs
@@ -37,7 +37,6 @@ import Name           ( Name, NamedThing(..), nameUnique )
 import Var             ( TyVar, Id )
 import FieldLabel      ( FieldLabel )
 import BasicTypes      ( Arity, StrictnessMark(..) )
-import NewDemand       ( Demand, lazyDmd, seqDmd )
 import Outputable
 import Unique          ( Unique, Uniquable(..) )
 import CmdLineOpts     ( opt_UnboxStrictFields )
@@ -114,7 +113,7 @@ data DataCon
        dcRepArgTys :: [Type],          -- Final, representation argument types, after unboxing and flattening,
                                        -- and including existential dictionaries
 
-       dcRepStrictness :: [Demand],    -- One for each representation argument 
+       dcRepStrictness :: [StrictnessMark],    -- One for each representation argument 
 
        dcTyCon  :: TyCon,              -- Result tycon
 
@@ -228,7 +227,7 @@ mkDataCon name arg_stricts fields
                  dcOrigArgTys = orig_arg_tys,
                  dcRepArgTys = rep_arg_tys,
                  dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
-                 dcStrictMarks = real_stricts, dcRepStrictness = rep_arg_demands,
+                 dcStrictMarks = real_stricts, dcRepStrictness = rep_arg_stricts,
                  dcFields = fields, dcTag = tag, dcTyCon = tycon, dcRepType = ty,
                  dcId = work_id, dcWrapId = wrap_id}
 
@@ -239,13 +238,10 @@ mkDataCon name arg_stricts fields
     real_stricts = (map mk_dict_strict_mark ex_dict_tys) ++
                   zipWithEqual "mkDataCon1" (chooseBoxingStrategy tycon) 
                                orig_arg_tys arg_stricts 
+    real_arg_tys = ex_dict_tys ++ orig_arg_tys
 
        -- Representation arguments and demands
-    (rep_arg_demands, rep_arg_tys) 
-       = unzip $ concat $ 
-         zipWithEqual "mkDataCon2" unbox_strict_arg_ty 
-                      real_stricts 
-                      (ex_dict_tys ++ orig_arg_tys)
+    (rep_arg_stricts, rep_arg_tys) = computeRep real_stricts real_arg_tys
 
     tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
     ty  = mkForAllTys (tyvars ++ ex_tyvars)
@@ -300,7 +296,7 @@ dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys
 
 isNullaryDataCon con  = dataConRepArity con == 0
 
-dataConRepStrictness :: DataCon -> [Demand]
+dataConRepStrictness :: DataCon -> [StrictnessMark]
        -- Give the demands on the arguments of a
        -- Core constructor application (Con dc args)
 dataConRepStrictness dc = dcRepStrictness dc
@@ -442,15 +438,18 @@ chooseBoxingStrategy tycon arg_ty strict
                                Nothing -> False
                                Just (arg_tycon, _) -> isProductTyCon arg_tycon
 
-unbox_strict_arg_ty 
-       :: StrictnessMark       -- After strategy choice; can't be MarkedUserStrict
-       -> Type                 -- Source argument type
-       -> [(Demand,Type)]      -- Representation argument types and demamds
+computeRep :: [StrictnessMark]         -- Original arg strictness
+                                       --   [after strategy choice; can't be MarkedUserStrict]
+          -> [Type]                    -- and types
+          -> ([StrictnessMark],        -- Representation arg strictness
+              [Type])                  -- And type
 
-unbox_strict_arg_ty NotMarkedStrict ty = [(lazyDmd, ty)]
-unbox_strict_arg_ty MarkedStrict    ty = [(seqDmd,  ty)]
-unbox_strict_arg_ty MarkedUnboxed   ty 
-  = zipEqual "unbox_strict_arg_ty" (dataConRepStrictness arg_data_con) arg_tys
+computeRep stricts tys
+  = unzip $ concat $ zipWithEqual "computeRep" unbox stricts tys
   where
-    (_, _, arg_data_con, arg_tys) = splitProductType "unbox_strict_arg_ty" (repType ty)
+    unbox NotMarkedStrict ty = [(NotMarkedStrict, ty)]
+    unbox MarkedStrict    ty = [(MarkedStrict,    ty)]
+    unbox MarkedUnboxed   ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys
+                            where
+                              (_, _, arg_dc, arg_tys) = splitProductType "unbox_strict_arg_ty" (repType ty)
 \end{code}

diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 34fc015..ea1d2cb 100644 (file)
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -50,6 +50,7 @@ import CoreUtils      ( cheapEqExpr, exprIsDupable, exprIsTrivial,
                          mkCoerce, mkSCC, mkInlineMe, mkAltExpr
                        )
 import Rules           ( lookupRule )
+import BasicTypes      ( isMarkedStrict )
 import CostCentre      ( currentCCS )
 import Type            ( mkTyVarTys, isUnLiftedType, seqType,
                          mkFunTy, splitTyConApp_maybe, tyConAppArgs,
@@ -1479,11 +1480,12 @@ simplAlts zap_occ_info scrut_cons case_bndr' alts cont'
 
     cat_evals [] [] = []
     cat_evals (v:vs) (str:strs)
-       | isTyVar v       = v                                   : cat_evals vs (str:strs)
-       | isStrictDmd str = (v' `setIdUnfolding` mkOtherCon []) : cat_evals vs strs
-       | otherwise       = v'                                  : cat_evals vs strs
+       | isTyVar v          = v        : cat_evals vs (str:strs)
+       | isMarkedStrict str = evald_v  : cat_evals vs strs
+       | otherwise          = zapped_v : cat_evals vs strs
        where
-         v' = zap_occ_info v
+         zapped_v = zap_occ_info v
+         evald_v  = zapped_v `setIdUnfolding` mkOtherCon []
 \end{code}