Commit 3063cb3d authored by simonpj's avatar simonpj
Browse files

[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.
parent 7849c8aa
......@@ -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}
......@@ -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,
......@@ -1480,10 +1481,11 @@ 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
| 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}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment