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 ) ...@@ -37,7 +37,6 @@ import Name ( Name, NamedThing(..), nameUnique )
import Var ( TyVar, Id ) import Var ( TyVar, Id )
import FieldLabel ( FieldLabel ) import FieldLabel ( FieldLabel )
import BasicTypes ( Arity, StrictnessMark(..) ) import BasicTypes ( Arity, StrictnessMark(..) )
import NewDemand ( Demand, lazyDmd, seqDmd )
import Outputable import Outputable
import Unique ( Unique, Uniquable(..) ) import Unique ( Unique, Uniquable(..) )
import CmdLineOpts ( opt_UnboxStrictFields ) import CmdLineOpts ( opt_UnboxStrictFields )
...@@ -114,7 +113,7 @@ data DataCon ...@@ -114,7 +113,7 @@ data DataCon
dcRepArgTys :: [Type], -- Final, representation argument types, after unboxing and flattening, dcRepArgTys :: [Type], -- Final, representation argument types, after unboxing and flattening,
-- and including existential dictionaries -- and including existential dictionaries
dcRepStrictness :: [Demand], -- One for each representation argument dcRepStrictness :: [StrictnessMark], -- One for each representation argument
dcTyCon :: TyCon, -- Result tycon dcTyCon :: TyCon, -- Result tycon
...@@ -228,7 +227,7 @@ mkDataCon name arg_stricts fields ...@@ -228,7 +227,7 @@ mkDataCon name arg_stricts fields
dcOrigArgTys = orig_arg_tys, dcOrigArgTys = orig_arg_tys,
dcRepArgTys = rep_arg_tys, dcRepArgTys = rep_arg_tys,
dcExTyVars = ex_tyvars, dcExTheta = ex_theta, 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, dcFields = fields, dcTag = tag, dcTyCon = tycon, dcRepType = ty,
dcId = work_id, dcWrapId = wrap_id} dcId = work_id, dcWrapId = wrap_id}
...@@ -239,13 +238,10 @@ mkDataCon name arg_stricts fields ...@@ -239,13 +238,10 @@ mkDataCon name arg_stricts fields
real_stricts = (map mk_dict_strict_mark ex_dict_tys) ++ real_stricts = (map mk_dict_strict_mark ex_dict_tys) ++
zipWithEqual "mkDataCon1" (chooseBoxingStrategy tycon) zipWithEqual "mkDataCon1" (chooseBoxingStrategy tycon)
orig_arg_tys arg_stricts orig_arg_tys arg_stricts
real_arg_tys = ex_dict_tys ++ orig_arg_tys
-- Representation arguments and demands -- Representation arguments and demands
(rep_arg_demands, rep_arg_tys) (rep_arg_stricts, rep_arg_tys) = computeRep real_stricts real_arg_tys
= unzip $ concat $
zipWithEqual "mkDataCon2" unbox_strict_arg_ty
real_stricts
(ex_dict_tys ++ orig_arg_tys)
tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
ty = mkForAllTys (tyvars ++ ex_tyvars) ty = mkForAllTys (tyvars ++ ex_tyvars)
...@@ -300,7 +296,7 @@ dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys ...@@ -300,7 +296,7 @@ dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys
isNullaryDataCon con = dataConRepArity con == 0 isNullaryDataCon con = dataConRepArity con == 0
dataConRepStrictness :: DataCon -> [Demand] dataConRepStrictness :: DataCon -> [StrictnessMark]
-- Give the demands on the arguments of a -- Give the demands on the arguments of a
-- Core constructor application (Con dc args) -- Core constructor application (Con dc args)
dataConRepStrictness dc = dcRepStrictness dc dataConRepStrictness dc = dcRepStrictness dc
...@@ -442,15 +438,18 @@ chooseBoxingStrategy tycon arg_ty strict ...@@ -442,15 +438,18 @@ chooseBoxingStrategy tycon arg_ty strict
Nothing -> False Nothing -> False
Just (arg_tycon, _) -> isProductTyCon arg_tycon Just (arg_tycon, _) -> isProductTyCon arg_tycon
unbox_strict_arg_ty computeRep :: [StrictnessMark] -- Original arg strictness
:: StrictnessMark -- After strategy choice; can't be MarkedUserStrict -- [after strategy choice; can't be MarkedUserStrict]
-> Type -- Source argument type -> [Type] -- and types
-> [(Demand,Type)] -- Representation argument types and demamds -> ([StrictnessMark], -- Representation arg strictness
[Type]) -- And type
unbox_strict_arg_ty NotMarkedStrict ty = [(lazyDmd, ty)] computeRep stricts tys
unbox_strict_arg_ty MarkedStrict ty = [(seqDmd, ty)] = unzip $ concat $ zipWithEqual "computeRep" unbox stricts tys
unbox_strict_arg_ty MarkedUnboxed ty
= zipEqual "unbox_strict_arg_ty" (dataConRepStrictness arg_data_con) arg_tys
where 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} \end{code}
...@@ -50,6 +50,7 @@ import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial, ...@@ -50,6 +50,7 @@ import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial,
mkCoerce, mkSCC, mkInlineMe, mkAltExpr mkCoerce, mkSCC, mkInlineMe, mkAltExpr
) )
import Rules ( lookupRule ) import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict )
import CostCentre ( currentCCS ) import CostCentre ( currentCCS )
import Type ( mkTyVarTys, isUnLiftedType, seqType, import Type ( mkTyVarTys, isUnLiftedType, seqType,
mkFunTy, splitTyConApp_maybe, tyConAppArgs, mkFunTy, splitTyConApp_maybe, tyConAppArgs,
...@@ -1479,11 +1480,12 @@ simplAlts zap_occ_info scrut_cons case_bndr' alts cont' ...@@ -1479,11 +1480,12 @@ simplAlts zap_occ_info scrut_cons case_bndr' alts cont'
cat_evals [] [] = [] cat_evals [] [] = []
cat_evals (v:vs) (str:strs) cat_evals (v:vs) (str:strs)
| isTyVar v = v : cat_evals vs (str:strs) | isTyVar v = v : cat_evals vs (str:strs)
| isStrictDmd str = (v' `setIdUnfolding` mkOtherCon []) : cat_evals vs strs | isMarkedStrict str = evald_v : cat_evals vs strs
| otherwise = v' : cat_evals vs strs | otherwise = zapped_v : cat_evals vs strs
where where
v' = zap_occ_info v zapped_v = zap_occ_info v
evald_v = zapped_v `setIdUnfolding` mkOtherCon []
\end{code} \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