#include "HsVersions.h"
-import {-# SOURCE #-} Subst( substTy, mkTyVarSubst )
+import {-# SOURCE #-} Subst( substTyWith )
+import {-# SOURCE #-} PprType( pprType )
-import CmdLineOpts ( opt_DictsStrict )
-import Type ( Type, TauType, ThetaType,
+import Type ( Type, TauType, ThetaType,
mkForAllTys, mkFunTys, mkTyConApp,
- mkTyVarTys, mkPredTys, getClassPredTys_maybe,
- splitTyConApp_maybe, repType
+ mkTyVarTys, splitTyConApp_maybe, repType,
+ mkPredTys, isStrictType
)
-import TyCon ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isDataTyCon, isProductTyCon,
+import TyCon ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isProductTyCon,
isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon )
import Class ( Class, classTyCon )
import Name ( Name, NamedThing(..), nameUnique )
import Var ( TyVar, Id )
import FieldLabel ( FieldLabel )
-import BasicTypes ( Arity )
-import Demand ( Demand, StrictnessMark(..), wwStrict, wwLazy )
+import BasicTypes ( Arity, StrictnessMark(..) )
import Outputable
import Unique ( Unique, Uniquable(..) )
import CmdLineOpts ( opt_UnboxStrictFields )
-import PprType () -- Instances
import Maybe
import ListSetOps ( assoc )
import Util ( zipEqual, zipWithEqual )
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
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}
-- Strictness marks for source-args
-- *after unboxing choices*,
-- but *including existential dictionaries*
- real_stricts = (map mk_dict_strict_mark ex_theta) ++
+ ex_dict_tys = mkPredTys ex_theta
+ 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
- (mkPredTys ex_theta ++ 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)
result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
-mk_dict_strict_mark pred
- | opt_DictsStrict, -- Don't mark newtype things as strict!
- Just (clas,_) <- getClassPredTys_maybe pred,
- isDataTyCon (classTyCon clas) = MarkedStrict
- | otherwise = NotMarkedStrict
+mk_dict_strict_mark ty | isStrictType ty = MarkedStrict
+ | otherwise = NotMarkedStrict
\end{code}
\begin{code}
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
dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars,
dcExTyVars = ex_tyvars}) inst_tys
- = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys)) arg_tys
+ = map (substTyWith (tyvars ++ ex_tyvars) inst_tys) arg_tys
dataConTheta :: DataCon -> ThetaType
dataConTheta dc = dcTheta dc
dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars,
dcExTyVars = ex_tyvars}) inst_tys
- = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys)) arg_tys
+ = map (substTyWith (tyvars ++ ex_tyvars) inst_tys) arg_tys
\end{code}
These two functions get the real argument types of the constructor,
splitProductType str ty
= case splitProductType_maybe ty of
Just stuff -> stuff
- Nothing -> pprPanic (str ++ ": not a product") (ppr ty)
+ Nothing -> pprPanic (str ++ ": not a product") (pprType ty)
-- We attempt to unbox/unpack a strict field when either:
-- (i) The tycon is imported, and the field is marked '! !', or
Nothing -> False
Just (arg_tycon, _) -> isProductTyCon arg_tycon
-unbox_strict_arg_ty
- :: StrictnessMark -- After strategy choice; can't be MkaredUserStrict
- -> 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 = [(wwLazy, ty)]
-unbox_strict_arg_ty MarkedStrict ty = [(wwStrict, 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}