From 3063cb3d629610339d5f1c38d244617977c5fd21 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 14 Sep 2001 15:44:13 +0000 Subject: [PATCH] [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. --- ghc/compiler/basicTypes/DataCon.lhs | 35 +++++++++++++++++------------------ ghc/compiler/simplCore/Simplify.lhs | 10 ++++++---- 2 files changed, 23 insertions(+), 22 deletions(-) diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index b5a093e..077e138 100644 --- 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 --- 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} -- 1.7.10.4