#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, ThetaType,
mkForAllTys, mkFunTys, mkTyConApp,
- mkTyVarTys, mkPredTys, getClassPredTys_maybe,
- splitTyConApp_maybe
+ 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 )
+import Util ( zipEqual, zipWithEqual, equalLength )
\end{code}
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
-> [StrictnessMark] -> [FieldLabel]
-> [TyVar] -> ThetaType
-> [TyVar] -> ThetaType
- -> [TauType] -> TyCon
+ -> [Type] -> TyCon
-> Id -> Id
-> DataCon
-- Can get the tag from the TyCon
mkDataCon name arg_stricts fields
tyvars theta ex_tyvars ex_theta orig_arg_tys tycon
work_id wrap_id
- = ASSERT(length arg_stricts == length orig_arg_tys)
+ = ASSERT(equalLength arg_stricts orig_arg_tys)
-- The 'stricts' passed to mkDataCon are simply those for the
-- source-language arguments. We add extra ones for the
-- dictionary arguments right here.
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
dataConSig :: DataCon -> ([TyVar], ThetaType,
[TyVar], ThetaType,
- [TauType], TyCon)
+ [Type], TyCon)
dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta,
dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
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,
dataConOrigArgTys :: DataCon -> [Type]
dataConOrigArgTys dc = dcOrigArgTys dc
-dataConRepArgTys :: DataCon -> [TauType]
+dataConRepArgTys :: DataCon -> [Type]
dataConRepArgTys dc = dcRepArgTys dc
\end{code}
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
-- Transforms any MarkedUserStricts into MarkUnboxed or MarkedStrict
chooseBoxingStrategy tycon arg_ty strict
= case strict of
- MarkedUserStrict | unbox arg_ty -> MarkedUnboxed
- | otherwise -> MarkedStrict
- other -> strict
+ MarkedUserStrict
+ | opt_UnboxStrictFields
+ && unbox arg_ty -> MarkedUnboxed
+ | otherwise -> MarkedStrict
+ other -> strict
where
- unbox ty = opt_UnboxStrictFields &&
- case splitTyConApp_maybe ty of
- Just (arg_tycon, _) -> not (isRecursiveTyCon arg_tycon) &&
- isProductTyCon arg_tycon &&
- isDataTyCon arg_tycon
- Nothing -> False
- -- Recursion: check whether the *argument* type constructor is
- -- recursive. Checking the *parent* tycon is over-conservative
- --
- -- We can't look through newtypes in arguments (yet); hence isDataTyCon
-
-
-unbox_strict_arg_ty
- :: StrictnessMark -- After strategy choice; can't be MkaredUserStrict
- -> Type -- Source argument type
- -> [(Demand,Type)] -- Representation argument types and demamds
-
-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
+ -- beware: repType will go into a loop if we try this on a recursive
+ -- type (for reasons unknown...), hence the check for recursion below.
+ unbox ty =
+ case splitTyConApp_maybe ty of
+ Nothing -> False
+ Just (arg_tycon, _)
+ | isRecursiveTyCon arg_tycon -> False
+ | otherwise ->
+ case splitTyConApp_maybe (repType ty) of
+ Nothing -> False
+ Just (arg_tycon, _) -> isProductTyCon arg_tycon
+
+computeRep :: [StrictnessMark] -- Original arg strictness
+ -- [after strategy choice; can't be MarkedUserStrict]
+ -> [Type] -- and types
+ -> ([StrictnessMark], -- Representation arg strictness
+ [Type]) -- And type
+
+computeRep stricts tys
+ = unzip $ concat $ zipWithEqual "computeRep" unbox stricts tys
where
- (_, _, arg_data_con, arg_tys) = splitProductType "unbox_strict_arg_ty" 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}