getUniqFlt :: FlatM Unique
getUniqFlt us = uniqFromSupply us
-getUniqsFlt :: Int -> FlatM [Unique]
-getUniqsFlt i us = uniqsFromSupply i us
+getUniqsFlt :: FlatM [Unique]
+getUniqsFlt us = uniqsFromSupply us
\end{code}
%************************************************************************
returnFlt (CAssign the_temp src, CAssign dest the_temp)
go_via_temps (COpStmt dests op srcs vol_regs)
- = getUniqsFlt (length dests) `thenFlt` \ uniqs ->
+ = getUniqsFlt `thenFlt` \ uniqs ->
let
the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
in
isExistentialDataCon, classDataCon,
splitProductType_maybe, splitProductType,
-
- StrictnessMark(..), -- Representation visible to MkId only
- markedStrict, notMarkedStrict, markedUnboxed, maybeMarkedUnboxed
) where
#include "HsVersions.h"
import Var ( TyVar, Id )
import FieldLabel ( FieldLabel )
import BasicTypes ( Arity )
-import Demand ( Demand, wwStrict, wwLazy )
+import Demand ( Demand, StrictnessMark(..), wwStrict, wwLazy )
import Outputable
import Unique ( Unique, Uniquable(..) )
import CmdLineOpts ( opt_UnboxStrictFields )
import PprType () -- Instances
-import Maybes ( maybeToBool )
import Maybe
import ListSetOps ( assoc )
+import Util ( zipEqual, zipWithEqual )
\end{code}
dcRepArgTys :: [Type], -- Final, representation argument types, after unboxing and flattening,
-- and including existential dictionaries
+ dcRepStrictness :: [Demand], -- One for each representation argument
+
dcTyCon :: TyCon, -- Result tycon
-- Now the strictness annotations and field labels of the constructor
- dcUserStricts :: [StrictnessMark],
- -- Strictness annotations, as placed on the data type defn,
- -- in the same order as the argument types;
- -- length = dataConSourceArity dataCon
-
- dcRealStricts :: [StrictnessMark],
- -- Strictness annotations as deduced by the compiler. May
- -- include some MarkedUnboxed fields that are merely MarkedStrict
- -- in dcUserStricts. Also includes the existential dictionaries.
+ dcStrictMarks :: [StrictnessMark],
+ -- Strictness annotations as deduced by the compiler.
+ -- Has no MarkedUserStrict; they have been changed to MarkedStrict
+ -- or MarkedUnboxed by the compiler.
+ -- *Includes the existential dictionaries*
-- length = length dcExTheta + dataConSourceArity dataCon
dcFields :: [FieldLabel],
%************************************************************************
%* *
-\subsection{Strictness indication}
-%* *
-%************************************************************************
-
-\begin{code}
-data StrictnessMark = MarkedStrict
- | MarkedUnboxed DataCon [Type]
- | NotMarkedStrict
-
-markedStrict = MarkedStrict
-notMarkedStrict = NotMarkedStrict
-markedUnboxed = MarkedUnboxed (panic "markedUnboxed1") (panic "markedUnboxed2")
-
-maybeMarkedUnboxed (MarkedUnboxed dc tys) = Just (dc,tys)
-maybeMarkedUnboxed other = Nothing
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Instances}
%* *
%************************************************************************
dcOrigArgTys = orig_arg_tys,
dcRepArgTys = rep_arg_tys,
dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
- dcRealStricts = all_stricts, dcUserStricts = user_stricts,
+ dcStrictMarks = real_stricts, dcRepStrictness = rep_arg_demands,
dcFields = fields, dcTag = tag, dcTyCon = tycon, dcRepType = ty,
dcId = work_id, dcWrapId = wrap_id}
- (real_arg_stricts, strict_arg_tyss)
- = unzip (zipWith (unbox_strict_arg_ty tycon) arg_stricts orig_arg_tys)
- rep_arg_tys = mkPredTys ex_theta ++ concat strict_arg_tyss
-
- ex_dict_stricts = map mk_dict_strict_mark ex_theta
- -- Add a strictness flag for the existential dictionary arguments
- all_stricts = ex_dict_stricts ++ real_arg_stricts
- user_stricts = ex_dict_stricts ++ arg_stricts
+ -- Strictness marks for source-args
+ -- *after unboxing choices*,
+ -- but *including existential dictionaries*
+ real_stricts = (map mk_dict_strict_mark ex_theta) ++
+ zipWithEqual "mkDataCon1" (chooseBoxingStrategy tycon)
+ orig_arg_tys arg_stricts
+
+ -- 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)
tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
ty = mkForAllTys (tyvars ++ ex_tyvars)
dataConFieldLabels = dcFields
dataConStrictMarks :: DataCon -> [StrictnessMark]
-dataConStrictMarks = dcRealStricts
+dataConStrictMarks = dcStrictMarks
-- Number of type-instantiation arguments
-- All the remaining arguments of the DataCon are (notionally)
dataConRepStrictness :: DataCon -> [Demand]
-- Give the demands on the arguments of a
-- Core constructor application (Con dc args)
-dataConRepStrictness dc
- = go (dcRealStricts dc)
- where
- go [] = []
- go (MarkedStrict : ss) = wwStrict : go ss
- go (NotMarkedStrict : ss) = wwLazy : go ss
- go (MarkedUnboxed con _ : ss) = go (dcRealStricts con ++ ss)
+dataConRepStrictness dc = dcRepStrictness dc
dataConSig :: DataCon -> ([TyVar], ThetaType,
[TyVar], ThetaType,
-- some without, the compiler doesn't get confused about the constructor
-- representations.
-unbox_strict_arg_ty :: TyCon -> StrictnessMark -> Type -> (StrictnessMark, [Type])
-
-unbox_strict_arg_ty tycon strict_mark ty
- | case strict_mark of
- NotMarkedStrict -> False
- MarkedUnboxed _ _ -> True -- !! From interface file
- MarkedStrict -> opt_UnboxStrictFields && -- ! From source
- maybeToBool maybe_product &&
- not (isRecursiveTyCon tycon) &&
- isDataTyCon arg_tycon
- -- We can't look through newtypes in arguments (yet)
- = (MarkedUnboxed con arg_tys, arg_tys)
+chooseBoxingStrategy :: TyCon -> Type -> StrictnessMark -> StrictnessMark
+ -- Transforms any MarkedUserStricts into MarkUnboxed or MarkedStrict
+chooseBoxingStrategy tycon arg_ty strict
+ = case strict of
+ MarkedUserStrict | 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
- | otherwise
- = (strict_mark, [ty])
+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
where
- maybe_product = splitProductType_maybe ty
- Just (arg_tycon, _, con, arg_tys) = maybe_product
+ (_, _, arg_data_con, arg_tys) = splitProductType "unbox_strict_arg_ty" ty
+
\end{code}
noStrictnessInfo,
ppStrictnessInfo, seqStrictnessInfo,
isBottomingStrictness, appIsBottom,
+
+ StrictnessMark(..), isMarkedUnboxed, isMarkedStrict
) where
#include "HsVersions.h"
ppStrictnessInfo (StrictnessInfo wrapper_args bot) = hsep [pprDemands wrapper_args bot]
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Strictness indication}
+%* *
+%************************************************************************
+
+The strictness annotations on types in data type declarations
+e.g. data T = MkT !Int !(Bool,Bool)
+
+\begin{code}
+data StrictnessMark
+ = MarkedUserStrict -- "!" in a source decl
+ | MarkedStrict -- "!" in an interface decl: strict but not unboxed
+ | MarkedUnboxed -- "!!" in an interface decl: unboxed
+ | NotMarkedStrict -- No annotation at all
+ deriving( Eq )
+
+isMarkedUnboxed MarkedUnboxed = True
+isMarkedUnboxed other = False
+
+isMarkedStrict NotMarkedStrict = False
+isMarkedStrict other = True -- All others are strict
+
+instance Outputable StrictnessMark where
+ ppr MarkedUserStrict = ptext SLIT("!u")
+ ppr MarkedStrict = ptext SLIT("!")
+ ppr MarkedUnboxed = ptext SLIT("! !")
+ ppr NotMarkedStrict = empty
+\end{code}
+
+
import FieldLabel ( FieldLabel )
import SrcLoc ( SrcLoc )
import Outputable
-import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques,
- getNumBuiltinUniques )
+import Unique ( Unique, mkBuiltinUnique )
infixl 1 `setIdUnfolding`,
`setIdArityInfo`,
-- "Template locals" typically used in unfoldings
mkTemplateLocals :: [Type] -> [Id]
-mkTemplateLocals tys = zipWith (mkSysLocal SLIT("tpl"))
- (getBuiltinUniques (length tys))
- tys
+mkTemplateLocals tys = zipWith mkTemplateLocal [1..] tys
mkTemplateLocalsNum :: Int -> [Type] -> [Id]
-- The Int gives the starting point for unique allocation
-mkTemplateLocalsNum n tys = zipWith (mkSysLocal SLIT("tpl"))
- (getNumBuiltinUniques n (length tys))
- tys
+mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys
mkTemplateLocal :: Int -> Type -> Id
mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty
mkDictSelId,
mkDataConId, mkDataConWrapId,
- mkRecordSelId,
+ mkRecordSelId, rebuildConArgs,
mkPrimOpId, mkCCallOpId,
-- And some particular Ids; see below for why they are wired in
primOpSig, mkPrimOpIdName,
CCall, pprCCallOp
)
-import Demand ( wwStrict, wwPrim, mkStrictnessInfo )
-import DataCon ( DataCon, StrictnessMark(..),
+import Demand ( wwStrict, wwPrim, mkStrictnessInfo,
+ StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
+import DataCon ( DataCon,
dataConFieldLabels, dataConRepArity, dataConTyCon,
dataConArgTys, dataConRepType, dataConRepStrictness,
dataConInstOrigArgTys,
dataConName, dataConTheta,
dataConSig, dataConStrictMarks, dataConId,
- maybeMarkedUnboxed, splitProductType_maybe
+ splitProductType
)
-import Id ( idType, mkGlobalId, mkVanillaGlobal,
+import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
mkTemplateLocals, mkTemplateLocalsNum,
mkTemplateLocal, idCprInfo
)
firstFieldLabelTag, allFieldLabelTags, fieldLabelType
)
import CoreSyn
+import Unique ( mkBuiltinUnique )
import Maybes
import PrelNames
import Maybe ( isJust )
mkLams tyvars $ mkLams dict_args $ Lam id_arg1 $
Note (Coerce result_ty (head orig_arg_tys)) (Var id_arg1)
- | null dict_args && all not_marked_strict strict_marks
+ | null dict_args && not (any isMarkedStrict strict_marks)
= Var work_id -- The common case. Not only is this efficient,
-- but it also ensures that the wrapper is replaced
-- by the worker even when there are no args.
(id_arg1:_) = id_args -- Used for newtype only
strict_marks = dataConStrictMarks data_con
- not_marked_strict NotMarkedStrict = True
- not_marked_strict other = False
-
mk_case
- :: (Id, StrictnessMark) -- arg, strictness
- -> (Int -> [Id] -> CoreExpr) -- body
- -> Int -- next rep arg id
- -> [Id] -- rep args so far
+ :: (Id, StrictnessMark) -- Arg, strictness
+ -> (Int -> [Id] -> CoreExpr) -- Body
+ -> Int -- Next rep arg id
+ -> [Id] -- Rep args so far, reversed
-> CoreExpr
mk_case (arg,strict) body i rep_args
= case strict of
| otherwise ->
Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))]
- MarkedUnboxed con tys ->
+ MarkedUnboxed ->
Case (Var arg) arg [(DataAlt con, con_args,
- body i' (reverse con_args++rep_args))]
+ body i' (reverse con_args ++ rep_args))]
where
- (con_args,i') = mkLocals i tys
+ (con_args, i') = mkLocals i tys
+ (_, _, con, tys) = splitProductType "mk_case" (idType arg)
\end{code}
mk_maybe_alt data_con
= case maybe_the_arg_id of
Nothing -> Nothing
- Just the_arg_id -> Just (DataAlt data_con, real_args, expr)
+ Just the_arg_id -> Just (DataAlt data_con, real_args, mkLets binds body)
where
- body = mkVarApps (mkVarApps (Var the_arg_id) field_tyvars) field_dict_ids
- strict_marks = dataConStrictMarks data_con
- (expr, real_args) = rebuildConArgs data_con arg_ids strict_marks body
- unpack_base
+ body = mkVarApps (mkVarApps (Var the_arg_id) field_tyvars) field_dict_ids
+ strict_marks = dataConStrictMarks data_con
+ (binds, real_args) = rebuildConArgs arg_ids strict_marks
+ (map mkBuiltinUnique [unpack_base..])
where
arg_ids = mkTemplateLocalsNum field_base (dataConInstOrigArgTys data_con tyvar_tys)
full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
--- this rather ugly function converts the unpacked data con arguments back into
--- their packed form. It is almost the same as the version in DsUtils, except that
--- we use template locals here rather than newDsId (ToDo: merge these).
+-- This rather ugly function converts the unpacked data con
+-- arguments back into their packed form.
rebuildConArgs
- :: DataCon -- the con we're matching on
- -> [Id] -- the source-level args
- -> [StrictnessMark] -- the strictness annotations (per-arg)
- -> CoreExpr -- the body
- -> Int -- template local
- -> (CoreExpr, [Id])
-
-rebuildConArgs con [] stricts body i = (body, [])
-rebuildConArgs con (arg:args) stricts body i | isTyVar arg
- = let (body', args') = rebuildConArgs con args stricts body i
- in (body',arg:args')
-rebuildConArgs con (arg:args) (str:stricts) body i
- = case maybeMarkedUnboxed str of
- Just (pack_con1, _) ->
- case splitProductType_maybe (idType arg) of
- Just (_, tycon_args, pack_con, con_arg_tys) ->
- ASSERT( pack_con == pack_con1 )
- let unpacked_args = zipWith mkTemplateLocal [i..] con_arg_tys
- (body', real_args) = rebuildConArgs con args stricts body
- (i + length con_arg_tys)
- in
- (
- Let (NonRec arg (mkConApp pack_con
- (map Type tycon_args ++
- map Var unpacked_args))) body',
- unpacked_args ++ real_args
- )
-
- _ -> let (body', args') = rebuildConArgs con args stricts body i
- in (body', arg:args')
+ :: [Id] -- Source-level args
+ -> [StrictnessMark] -- Strictness annotations (per-arg)
+ -> [Unique] -- Uniques for the new Ids
+ -> ([CoreBind], [Id]) -- A binding for each source-level arg, plus
+ -- a list of the representation-level arguments
+-- e.g. data T = MkT Int !Int
+--
+-- rebuild [x::Int, y::Int] [Not, Unbox]
+-- = ([ y = I# t ], [x,t])
+
+rebuildConArgs [] stricts us = ([], [])
+
+-- Type variable case
+rebuildConArgs (arg:args) stricts us
+ | isTyVar arg
+ = let (binds, args') = rebuildConArgs args stricts us
+ in (binds, arg:args')
+
+-- Term variable case
+rebuildConArgs (arg:args) (str:stricts) us
+ | isMarkedUnboxed str
+ = let
+ (_, tycon_args, pack_con, con_arg_tys) = splitProductType "rebuildConArgs" (idType arg)
+ unpacked_args = zipWith (mkSysLocal SLIT("rb")) us con_arg_tys
+ (binds, args') = rebuildConArgs args stricts (drop (length con_arg_tys) us)
+ con_app = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
+ in
+ (NonRec arg con_app : binds, unpacked_args ++ args')
+
+ | otherwise
+ = let (binds, args') = rebuildConArgs args stricts us
+ in (binds, arg:args')
\end{code}
splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
uniqFromSupply :: UniqSupply -> Unique
-uniqsFromSupply :: Int -> UniqSupply -> [Unique]
+uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite
\end{code}
\begin{code}
\end{code}
\begin{code}
-uniqFromSupply (MkSplitUniqSupply (I# n) _ _) = mkUniqueGrimily n
-
-uniqsFromSupply (I# i) supply = i `get_from` supply
- where
- get_from 0# _ = []
- get_from n (MkSplitUniqSupply (I# u) _ s2)
- = mkUniqueGrimily u : get_from (n -# 1#) s2
+uniqFromSupply (MkSplitUniqSupply (I# n) _ _) = mkUniqueGrimily n
+uniqsFromSupply (MkSplitUniqSupply (I# n) _ s2) = mkUniqueGrimily n : uniqsFromSupply s2
\end{code}
%************************************************************************
getUniqueUs us = case splitUniqSupply us of
(us1,us2) -> (uniqFromSupply us1, us2)
-getUniquesUs :: Int -> UniqSM [Unique]
-getUniquesUs n us = case splitUniqSupply us of
- (us1,us2) -> (uniqsFromSupply n us1, us2)
+getUniquesUs :: UniqSM [Unique]
+getUniquesUs us = case splitUniqSupply us of
+ (us1,us2) -> (uniqsFromSupply us1, us2)
\end{code}
\begin{code}
mkPreludeMiscIdUnique, mkPreludeDataConUnique,
mkPreludeTyConUnique, mkPreludeClassUnique,
- getNumBuiltinUniques, getBuiltinUniques, mkBuiltinUnique,
+ mkBuiltinUnique,
mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3
) where
mkPseudoUnique1 i = mkUnique 'C' i -- used for getUnique on Regs
mkPseudoUnique2 i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs
mkPseudoUnique3 i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs
-
-
-
-getBuiltinUniques :: Int -> [Unique]
-getBuiltinUniques n = map (mkUnique 'B') [1 .. n]
-
-getNumBuiltinUniques :: Int -- First unique
- -> Int -- Number required
- -> [Unique]
-getNumBuiltinUniques base n = map (mkUnique 'B') [base .. base+n-1]
\end{code}
substAndCloneIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
substAndCloneIds subst us ids
- = mapAccumL (subst_clone_id subst) subst (ids `zip` uniqsFromSupply (length ids) us)
+ = mapAccumL (subst_clone_id subst) subst (ids `zip` uniqsFromSupply us)
substAndCloneRecIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
substAndCloneRecIds subst us ids
= (subst', ids')
where
(subst', ids') = mapAccumL (subst_clone_id subst') subst
- (ids `zip` uniqsFromSupply (length ids) us)
+ (ids `zip` uniqsFromSupply us)
substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, Id)
substAndCloneId subst@(Subst in_scope env) us old_id
newFailLocalDs,
getSrcLocDs, putSrcLocDs,
getModuleDs,
- getUniqueDs,
+ getUniqueDs, getUniquesDs,
getDOptsDs,
dsLookupGlobalValue,
getUniqueDs :: DsM Unique
getUniqueDs dflags us genv loc mod warns
- = case (uniqFromSupply us) of { assigned_uniq ->
- (assigned_uniq, warns) }
+ = (uniqFromSupply us, warns)
+
+getUniquesDs :: DsM [Unique]
+getUniquesDs dflags us genv loc mod warns
+ = (uniqsFromSupply us, warns)
getDOptsDs :: DsM DynFlags
getDOptsDs dflags us genv loc mod warns
cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
cloneTyVarsDs tyvars dflags us genv loc mod warns
- = case uniqsFromSupply (length tyvars) us of { uniqs ->
- (zipWithEqual "cloneTyVarsDs" setTyVarUnique tyvars uniqs, warns) }
+ = (zipWith setTyVarUnique tyvars (uniqsFromSupply us), warns)
\end{code}
\begin{code}
newTyVarsDs :: [TyVar] -> DsM [TyVar]
-
newTyVarsDs tyvar_tmpls dflags us genv loc mod warns
- = case uniqsFromSupply (length tyvar_tmpls) us of { uniqs ->
- (zipWithEqual "newTyVarsDs" setTyVarUnique tyvar_tmpls uniqs, warns) }
+ = (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply us), warns)
\end{code}
We can also reach out and either set/grab location information from
import CoreUtils ( exprType, mkIfThenElse )
import PrelInfo ( iRREFUT_PAT_ERROR_ID )
+import MkId ( rebuildConArgs )
import Id ( idType, Id, mkWildId )
import Literal ( Literal(..), inIntRange, tARGET_MAX_INT )
import TyCon ( isNewTyCon, tyConDataCons )
-import DataCon ( DataCon, StrictnessMark, maybeMarkedUnboxed,
- dataConStrictMarks, dataConId, splitProductType_maybe
- )
+import DataCon ( DataCon, dataConStrictMarks, dataConId )
import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp,
Type
)
returnDs (Case (Var var) wild_var (alts ++ mk_default fail))
mk_alt fail (con, args, MatchResult _ body_fn)
- = body_fn fail `thenDs` \ body ->
- rebuildConArgs con args (dataConStrictMarks con) body
- `thenDs` \ (body', real_args) ->
- returnDs (DataAlt con, real_args, body')
+ = body_fn fail `thenDs` \ body ->
+ getUniquesDs `thenDs` \ us ->
+ let
+ (binds, real_args) = rebuildConArgs args (dataConStrictMarks con) us
+ in
+ returnDs (DataAlt con, real_args, mkDsLets binds body)
mk_default fail | exhaustive_case = []
| otherwise = [(DEFAULT, [], fail)]
= mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
exhaustive_case = isEmptyUniqSet un_mentioned_constructors
\end{code}
-%
-For each constructor we match on, we might need to re-pack some
-of the strict fields if they are unpacked in the constructor.
-%
-\begin{code}
-rebuildConArgs
- :: DataCon -- the con we're matching on
- -> [Id] -- the source-level args
- -> [StrictnessMark] -- the strictness annotations (per-arg)
- -> CoreExpr -- the body
- -> DsM (CoreExpr, [Id])
-
-rebuildConArgs con [] stricts body = returnDs (body, [])
-rebuildConArgs con (arg:args) stricts body | isTyVar arg
- = rebuildConArgs con args stricts body `thenDs` \ (body', args') ->
- returnDs (body',arg:args')
-rebuildConArgs con (arg:args) (str:stricts) body
- = rebuildConArgs con args stricts body `thenDs` \ (body', real_args) ->
- case maybeMarkedUnboxed str of
- Just (pack_con1, _) ->
- case splitProductType_maybe (idType arg) of
- Just (_, tycon_args, pack_con, con_arg_tys) ->
- ASSERT( pack_con == pack_con1 )
- newSysLocalsDs con_arg_tys `thenDs` \ unpacked_args ->
- returnDs (
- mkDsLet (NonRec arg (mkConApp pack_con
- (map Type tycon_args ++
- map Var unpacked_args))) body',
- unpacked_args ++ real_args
- )
-
- _ -> returnDs (body', arg:real_args)
-\end{code}
+
%************************************************************************
%* *
= dontAddErrLoc (ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id))
pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun
- = addWarnLocHdrLine loc message (nest 8 (rest_of_msg_fun pref))
+ = addWarnLocHdrLine loc
+ (ptext SLIT("Pattern match(es)") <+> msg)
+ (sep [ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)])
where
(ppr_match, pref)
= case kind of
FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
other -> (pprMatchContext kind <+> ppr_pats pats, \ pp -> pp)
-
- message = ptext SLIT("Pattern match(es)") <+> msg <+> ppr_match <> char ':'
ppr_pats pats = sep (map ppr pats)
DefaultDecl(..), ForeignDecl(..), ForKind(..),
ExtName(..), isDynamicExtName, extNameStatic,
ConDecl(..), ConDetails(..),
- BangType(..), getBangType,
+ BangType(..), getBangType, getBangStrictness, unbangedType,
DeprecDecl(..), DeprecTxt,
hsDeclName, instDeclName, tyClDeclName, tyClDeclNames, tyClDeclSysNames,
isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
)
import CoreSyn ( CoreRule(..) )
import BasicTypes ( NewOrData(..) )
+import Demand ( StrictnessMark(..) )
import CallConv ( CallConv, pprCallConv )
-- others:
\end{code}
\begin{code}
-data BangType name
- = Banged (HsType name) -- HsType: to allow Haskell extensions
- | Unbanged (HsType name) -- (MonoType only needed for straight Haskell)
- | Unpacked (HsType name) -- Field is strict and to be unpacked if poss.
-
-getBangType (Banged ty) = ty
-getBangType (Unbanged ty) = ty
-getBangType (Unpacked ty) = ty
-
-eq_btype env (Banged t1) (Banged t2) = eq_hsType env t1 t2
-eq_btype env (Unbanged t1) (Unbanged t2) = eq_hsType env t1 t2
-eq_btype env (Unpacked t1) (Unpacked t2) = eq_hsType env t1 t2
-eq_btype env _ _ = False
+data BangType name = BangType StrictnessMark (HsType name)
+
+getBangType (BangType _ ty) = ty
+getBangStrictness (BangType s _) = s
+
+unbangedType ty = BangType NotMarkedStrict ty
+
+eq_btype env (BangType s1 t1) (BangType s2 t2) = s1==s2 && eq_hsType env t1 t2
\end{code}
\begin{code}
instance Outputable name => Outputable (BangType name) where
ppr = ppr_bang
-ppr_bang (Banged ty) = ptext SLIT("!") <> pprParendHsType ty
-ppr_bang (Unbanged ty) = pprParendHsType ty
-ppr_bang (Unpacked ty) = ptext SLIT("! !") <> pprParendHsType ty
+ppr_bang (BangType s ty) = ppr s <> pprParendHsType ty
\end{code}
\end{code}
\begin{code}
-emptyModDetails :: ModDetails
-emptyModDetails
- = ModDetails { md_types = emptyTypeEnv,
- md_insts = [],
- md_rules = []
- }
-
emptyModIface :: Module -> ModIface
emptyModIface mod
= ModIface { mi_module = mod,
import Id ( idType, idInfo, isImplicitId, idCgInfo,
isLocalId, idName,
)
-import DataCon ( StrictnessMark(..), dataConId, dataConSig, dataConFieldLabels, dataConStrictMarks )
+import DataCon ( dataConId, dataConSig, dataConFieldLabels, dataConStrictMarks )
import IdInfo -- Lots
import CoreSyn ( CoreRule(..) )
import CoreFVs ( ruleLhsFreeNames )
where
(tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
field_labels = dataConFieldLabels data_con
- strict_marks = dataConStrictMarks data_con
+ strict_marks = drop (length ex_theta) (dataConStrictMarks data_con)
+ -- The 'drop' is because dataConStrictMarks
+ -- includes the existential dictionaries
details | null field_labels
= ASSERT( tycon == tycon1 && tyvars == tyvars1 )
- VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
+ VanillaCon (zipWith BangType strict_marks (map toHsType arg_tys))
| otherwise
= RecCon (zipWith mk_field strict_marks field_labels)
- mk_bang_ty NotMarkedStrict ty = Unbanged (toHsType ty)
- mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
- mk_bang_ty MarkedStrict ty = Banged (toHsType ty)
-
mk_field strict_mark field_label
- = ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
+ = ([getName field_label], BangType strict_mark (toHsType (fieldLabelType field_label)))
ifaceTyCls (AnId id) so_far
| isImplicitId id = so_far
import OccName ( dataName, varName, tcClsName,
occNameSpace, setOccNameSpace, occNameUserString )
import FastString ( unpackFS )
-import UniqFM ( UniqFM, listToUFM, lookupUFM )
+import UniqFM ( UniqFM, listToUFM )
import Outputable
-----------------------------------------------------------------------------
mkVanillaCon ty tys
= split ty tys
where
- split (HsAppTy t u) ts = split t (Unbanged u : ts)
+ split (HsAppTy t u) ts = split t (unbangedType u : ts)
split (HsTyVar tc) ts = tyConToDataCon tc `thenP` \ data_con ->
returnP (data_con, VanillaCon ts)
split _ _ = parseError "Illegal data/newtype declaration"
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.63 2001/05/09 13:05:07 simonpj Exp $
+$Id: Parser.y,v 1.64 2001/05/18 08:46:20 simonpj Exp $
Haskell grammar.
import SrcLoc ( SrcLoc )
import Module
import CallConv
+import Demand ( StrictnessMark(..) )
import CmdLineOpts ( opt_SccProfilingOn )
import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), NewOrData(..) )
import Panic
-- Datatype declarations
newconstr :: { RdrNameConDecl }
- : srcloc conid atype { mkConDecl $2 [] [] (VanillaCon [Unbanged $3]) $1 }
+ : srcloc conid atype { mkConDecl $2 [] [] (VanillaCon [unbangedType $3]) $1 }
| srcloc conid '{' var '::' type '}'
- { mkConDecl $2 [] [] (RecCon [([$4], Unbanged $6)]) $1 }
+ { mkConDecl $2 [] [] (RecCon [([$4], unbangedType $6)]) $1 }
constrs :: { [RdrNameConDecl] }
: constrs '|' constr { $3 : $1 }
constr_stuff :: { (RdrName, RdrNameConDetails) }
: btype {% mkVanillaCon $1 [] }
- | btype '!' atype satypes {% mkVanillaCon $1 (Banged $3 : $4) }
+ | btype '!' atype satypes {% mkVanillaCon $1 (BangType MarkedUserStrict $3 : $4) }
| gtycon '{' fielddecls '}' {% mkRecCon $1 $3 }
| sbtype conop sbtype { ($2, InfixCon $1 $3) }
satypes :: { [RdrNameBangType] }
- : atype satypes { Unbanged $1 : $2 }
- | '!' atype satypes { Banged $2 : $3 }
+ : atype satypes { unbangedType $1 : $2 }
+ | '!' atype satypes { BangType MarkedUserStrict $2 : $3 }
| {- empty -} { [] }
sbtype :: { RdrNameBangType }
- : btype { Unbanged $1 }
- | '!' atype { Banged $2 }
+ : btype { unbangedType $1 }
+ | '!' atype { BangType MarkedUserStrict $2 }
fielddecls :: { [([RdrName],RdrNameBangType)] }
: fielddecl ',' fielddecls { $1 : $3 }
: sig_vars '::' stype { (reverse $1, $3) }
stype :: { RdrNameBangType }
- : ctype { Unbanged $1 }
- | '!' atype { Banged $2 }
+ : ctype { unbangedType $1 }
+ | '!' atype { BangType MarkedUserStrict $2 }
deriving :: { Maybe [RdrName] }
: {- empty -} { Nothing }
nameModule, mkWiredInName )
import OccName ( mkOccFS, tcName, dataName, mkWorkerOcc, mkGenOcc1, mkGenOcc2 )
import RdrName ( rdrNameOcc )
-import DataCon ( DataCon, StrictnessMark(..), mkDataCon, dataConId )
+import DataCon ( DataCon, mkDataCon, dataConId )
+import Demand ( StrictnessMark(..) )
import Var ( TyVar, tyVarKind )
import TyCon ( TyCon, AlgTyConFlavour(..), tyConDataCons,
mkTupleTyCon, isUnLiftedTyCon, mkAlgTyCon
NewOrData(..), Version, initialVersion, Boxity(..)
)
import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) )
+import Demand ( StrictnessMark(..) )
import CallConv ( cCallConv )
import Type ( Kind, mkArrowKind, liftedTypeKind, openTypeKind, usageTypeKind )
import IdInfo ( InlinePragInfo(..) )
-- We use "data_fs" so as to include ()
newtype_constr :: { [RdrNameConDecl] {- Not allowed to be empty -} }
-newtype_constr : src_loc '=' ex_stuff qdata_name atype { [mk_con_decl $4 $3 (VanillaCon [Unbanged $5]) $1] }
+newtype_constr : src_loc '=' ex_stuff qdata_name atype { [mk_con_decl $4 $3 (VanillaCon [unbangedType $5]) $1] }
| src_loc '=' ex_stuff qdata_name '{' qvar_name '::' atype '}'
- { [mk_con_decl $4 $3 (RecCon [([$6], Unbanged $8)]) $1] }
+ { [mk_con_decl $4 $3 (RecCon [([$6], unbangedType $8)]) $1] }
ex_stuff :: { ([HsTyVarBndr RdrName], RdrNameContext) }
ex_stuff : { ([],[]) }
| batype batypes { $1 : $2 }
batype :: { RdrNameBangType }
-batype : tatype { Unbanged $1 }
- | '!' tatype { Banged $2 }
- | '!' '!' tatype { Unpacked $3 }
+batype : tatype { unbangedType $1 }
+ | '!' tatype { BangType MarkedStrict $2 }
+ | '!' '!' tatype { BangType MarkedUnboxed $3 }
fields1 :: { [([RdrName], RdrNameBangType)] }
fields1 : field { [$1] }
| field ',' fields1 { $1 : $3 }
field :: { ([RdrName], RdrNameBangType) }
-field : qvar_names1 '::' ttype { ($1, Unbanged $3) }
- | qvar_names1 '::' '!' ttype { ($1, Banged $4) }
- | qvar_names1 '::' '!' '!' ttype { ($1, Unpacked $5) }
+field : qvar_names1 '::' ttype { ($1, unbangedType $3) }
+ | qvar_names1 '::' '!' ttype { ($1, BangType MarkedStrict $4) }
+ | qvar_names1 '::' '!' '!' ttype { ($1, BangType MarkedUnboxed $5) }
--------------------------------------------------------------------------
returnRn (NoInlineSig new_v p src_loc)
\end{code}
-\begin{code}
-renameIE :: (RdrName -> RnMS Name) -> IE RdrName -> RnMS (IE Name, FreeVars)
-renameIE lookup_occ_nm (IEVar v)
- = lookup_occ_nm v `thenRn` \ new_v ->
- returnRn (IEVar new_v, unitFV new_v)
-
-renameIE lookup_occ_nm (IEThingAbs v)
- = lookup_occ_nm v `thenRn` \ new_v ->
- returnRn (IEThingAbs new_v, unitFV new_v)
-
-renameIE lookup_occ_nm (IEThingAll v)
- = lookup_occ_nm v `thenRn` \ new_v ->
- returnRn (IEThingAll new_v, unitFV new_v)
-
-renameIE lookup_occ_nm (IEThingWith v vs)
- = lookup_occ_nm v `thenRn` \ new_v ->
- mapRn lookup_occ_nm vs `thenRn` \ new_vs ->
- returnRn (IEThingWith new_v new_vs, plusFVs [ unitFV x | x <- new_v:new_vs ])
-
-renameIE lookup_occ_nm (IEModuleContents m)
- = returnRn (IEModuleContents m, emptyFVs)
-\end{code}
-
%************************************************************************
%* *
import HsSyn
import RdrHsSyn ( RdrNameIE )
-import RnHsSyn ( RenamedTyClDecl )
import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
mkRdrUnqual, mkRdrQual, lookupRdrEnv, foldRdrEnv
)
import PrelNames ( mkUnboundName, syntaxList, SyntaxMap, vanillaSyntaxMap,
derivingOccurrences,
mAIN_Name, pREL_MAIN_Name,
- ioTyConName, integerTyConName, doubleTyConName, intTyConName,
+ ioTyConName, intTyConName,
boolTyConName, funTyConName,
unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name,
eqStringName, printName,
- hasKey, fractionalClassKey, numClassKey,
bindIOName, returnIOName, failIOName
)
import TysWiredIn ( unitTyCon ) -- A little odd
newLocalsRn rdr_names_w_loc
= getNameSupplyRn `thenRn` \ name_supply ->
let
- n = length rdr_names_w_loc
(us', us1) = splitUniqSupply (nsUniqs name_supply)
- uniqs = uniqsFromSupply n us1
+ uniqs = uniqsFromSupply us1
names = [ mkLocalName uniq (rdrNameOcc rdr_name) loc
| ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
]
if b then returnRn hi_boot_ver_path
else returnRn hi_boot_path
| otherwise = returnRn hi_path
- where (Just hi_path) = ml_hi_file locn
- (hi_base, hi_suf) = splitFilename hi_path
- hi_boot_path = hi_base ++ ".hi-boot"
- hi_boot_ver_path = hi_base ++ ".hi-boot-" ++ cHscIfaceFileVersion
+ where (Just hi_path) = ml_hi_file locn
+ (hi_base, _hi_suf) = splitFilename hi_path
+ hi_boot_path = hi_base ++ ".hi-boot"
+ hi_boot_ver_path = hi_base ++ ".hi-boot-" ++ cHscIfaceFileVersion
\end{code}
@readIface@ tries just the one file.
rnBangTy doc ty `thenRn` \ new_ty ->
returnRn (new_names, new_ty)
-rnBangTy doc (Banged ty)
+rnBangTy doc (BangType s ty)
= rnHsType doc ty `thenRn` \ new_ty ->
- returnRn (Banged new_ty)
-
-rnBangTy doc (Unbanged ty)
- = rnHsType doc ty `thenRn` \ new_ty ->
- returnRn (Unbanged new_ty)
-
-rnBangTy doc (Unpacked ty)
- = rnHsType doc ty `thenRn` \ new_ty ->
- returnRn (Unpacked new_ty)
+ returnRn (BangType s new_ty)
-- This data decl will parse OK
-- data T = a Int
\begin{code}
newPolyBndrs dest_lvl env abs_vars bndrs
- = getUniquesUs (length bndrs) `thenLvl` \ uniqs ->
+ = getUniquesUs `thenLvl` \ uniqs ->
let
new_bndrs = zipWith mk_poly_bndr bndrs uniqs
in
= case splitUniqSupply us of
(us1, us2) -> (uniqFromSupply us1, us2, sc)
-getUniquesSmpl :: Int -> SimplM [Unique]
-getUniquesSmpl n dflags env us sc
+getUniquesSmpl :: SimplM [Unique]
+getUniquesSmpl dflags env us sc
= case splitUniqSupply us of
- (us1, us2) -> (uniqsFromSupply n us1, us2, sc)
+ (us1, us2) -> (uniqsFromSupply us1, us2, sc)
getDOptsSmpl :: SimplM DynFlags
getDOptsSmpl dflags env us sc
(us1, us2) -> m vs dflags (env {seSubst = Subst.extendNewInScopeList subst vs})
us2 sc
where
- vs = zipWithEqual "newIds" (mkSysLocal fs)
- (uniqsFromSupply (length tys) us1) tys
+ vs = zipWith (mkSysLocal fs) (uniqsFromSupply us1) tys
\end{code}
import PrelInfo ( realWorldPrimId )
import OrdList
import Maybes ( maybeToBool )
-import Util ( zipWithEqual )
import Outputable
\end{code}
let
(_,_,ex_tyvars,_,_,_) = dataConSig data_con
in
- getUniquesSmpl (length ex_tyvars) `thenSmpl` \ tv_uniqs ->
+ getUniquesSmpl `thenSmpl` \ tv_uniqs ->
let
- ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
+ ex_tyvars' = zipWith mk tv_uniqs ex_tyvars
mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
arg_tys = dataConArgTys data_con
(inst_tys ++ mkTyVarTys ex_tyvars')
-- Consider: let j = if .. then I# 3 else I# 4
-- in case .. of { A -> j; B -> j; C -> ... }
--
- -- Now CPR should not w/w j because it's a thunk, so
+ -- Now CPR doesn't w/w j because it's a thunk, so
-- that means that the enclosing function can't w/w either,
-- which is a lose. Here's the example that happened in practice:
-- kgmod :: Int -> Int -> Int
-- kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
-- then 78
-- else 5
+ --
+ -- I have seen a case alternative like this:
+ -- True -> \v -> ...
+ -- It's a bit silly to add the realWorld dummy arg in this case, making
+ -- $j = \s v -> ...
+ -- True -> $j s
+ -- (the \v alone is enough to make CPR happy) but I think it's rare
then newId SLIT("w") realWorldStatePrimTy $ \ rw_id ->
returnSmpl ([rw_id], [Var realWorldPrimId])
-- build lots of wrapper args:
-- \x. let v=E in \y. bottom
-- = \xy. let v=E in bottom
- = getUniquesUs n_args `thenUs` \ wrap_uniqs ->
+ = getUniquesUs `thenUs` \ wrap_uniqs ->
let
val_args = zipWith4 mk_wrap_arg wrap_uniqs arg_tys demands one_shots
wrap_args = tyvars ++ val_args
-- Unpack case
WwUnpack new_or_data True cs ->
- getUniquesUs (length inst_con_arg_tys) `thenUs` \ uniqs ->
+ getUniquesUs `thenUs` \ uniqs ->
let
unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys
unpk_args_w_ds = zipWithEqual "mk_ww_str" set_worker_arg_info unpk_args cs
| n_con_args == 1 && isUnLiftedType con_arg_ty1
-- Special case when there is a single result of unlifted type
- = getUniquesUs 2 `thenUs` \ [work_uniq, arg_uniq] ->
+ = getUniquesUs `thenUs` \ (work_uniq : arg_uniq : _) ->
let
work_wild = mk_ww_local work_uniq body_ty
arg = mk_ww_local arg_uniq con_arg_ty1
con_arg_ty1)
| otherwise -- The general case
- = getUniquesUs (n_con_args + 2) `thenUs` \ uniqs ->
+ = getUniquesUs `thenUs` \ uniqs ->
let
(wrap_wild : work_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : body_ty : con_arg_tys)
arg_vars = map Var args
isIntegerTy
)
import PrelNames( fromIntegerName, fromRationalName )
-import Util ( thenCmp, zipWithEqual )
+import Util ( thenCmp )
import Bag
import Outputable
\end{code}
-> TcThetaType
-> NF_TcM [Inst]
newDictsAtLoc inst_loc@(_,loc,_) theta
- = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
- returnNF_Tc (zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta)
+ = tcGetUniques `thenNF_Tc` \ new_uniqs ->
+ returnNF_Tc (zipWith mk_dict new_uniqs theta)
where
mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
import Class ( classTyVars, classBigSig, classTyCon,
Class, ClassOpItem, DefMeth (..) )
import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
-import DataCon ( mkDataCon, notMarkedStrict )
+import DataCon ( mkDataCon )
+import Demand ( StrictnessMark(..) )
import Id ( Id, idType, idName )
import Module ( Module )
import Name ( Name, NamedThing(..) )
dict_component_tys = sc_tys ++ op_tys
dict_con = mkDataCon datacon_name
- [notMarkedStrict | _ <- dict_component_tys]
+ [NotMarkedStrict | _ <- dict_component_tys]
[{- No labelled fields -}]
tyvars
[{-No context-}]
mkDefMethRhs is_inst_decl clas inst_tys sel_id loc NoDefMeth
= -- No default method
-- Warn only if -fwarn-missing-methods
- doptsTc Opt_WarnMissingMethods `thenNF_Tc` \ warn ->
+ doptsTc Opt_WarnMissingMethods `thenNF_Tc` \ warn ->
warnTc (is_inst_decl && warn)
- (omittedMethodWarn sel_id clas) `thenNF_Tc_`
+ (omittedMethodWarn sel_id) `thenNF_Tc_`
returnTc error_rhs
where
error_rhs = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
-- a type constructor applied to type arguments in the instance decl
-- (checkTc, so False provokes the error)
checkTc (not is_inst_decl || simple_inst)
- (badGenericInstance sel_id clas) `thenTc_`
+ (badGenericInstance sel_id) `thenTc_`
ioToTc (dumpIfSet opt_PprStyle_Debug "Generic RHS" stuff) `thenNF_Tc_`
returnTc rhs
= hsep [ptext SLIT("Class"), quotes (ppr clas),
ptext SLIT("does not have a method"), quotes (ppr op)]
-omittedMethodWarn sel_id clas
- = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id),
- ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
+omittedMethodWarn sel_id
+ = ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
badGenericMethodType op op_ty
= hang (ptext SLIT("Generic method type is too complex"))
4 (vcat [ppr op <+> dcolon <+> ppr op_ty,
ptext SLIT("You can only use type variables, arrows, and tuples")])
-badGenericInstance sel_id clas
+badGenericInstance sel_id
= sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
ptext SLIT("because the instance declaration is not for a simple type (T a b c)"),
- ptext SLIT("(where T is a derivable type constructor)"),
- ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
+ ptext SLIT("(where T is a derivable type constructor)")]
mixedGenericErr op
= ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
tcInstTyVars, tcInstType,
newTyVarTy, newTyVarTys, zonkTcType )
-import FieldLabel ( fieldLabelName, fieldLabelType, fieldLabelTyCon )
+import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
import Id ( idType, recordSelectorFieldLabel, isRecordSelector )
import DataCon ( dataConFieldLabels, dataConSig,
- dataConStrictMarks, StrictnessMark(..)
+ dataConStrictMarks
)
+import Demand ( isMarkedStrict )
import Name ( Name )
import Type ( mkFunTy, mkAppTy, mkTyConTy,
splitFunTy_maybe, splitFunTys,
thenMName, failMName, returnMName, ioTyConName
)
import Outputable
-import Maybes ( maybeToBool, mapMaybe )
+import Maybes ( maybeToBool )
import ListSetOps ( minusList )
import Util
import CmdLineOpts
tcRecordBinds tycon ty_args rbinds `thenTc` \ (rbinds', rbinds_lie) ->
let
- missing_s_fields = missingStrictFields rbinds data_con
+ (missing_s_fields, missing_fields) = missingFields rbinds data_con
in
checkTcM (null missing_s_fields)
(mapNF_Tc (addErrTc . missingStrictFieldCon con_name) missing_s_fields `thenNF_Tc_`
returnNF_Tc ()) `thenNF_Tc_`
- let
- missing_fields = missingFields rbinds data_con
- in
doptsTc Opt_WarnMissingFields `thenNF_Tc` \ warn ->
checkTcM (not (warn && not (null missing_fields)))
(mapNF_Tc ((warnTc True) . missingFieldCon con_name) missing_fields `thenNF_Tc_`
where
field_names = map fieldLabelName (dataConFieldLabels data_con)
-missingStrictFields rbinds data_con
- = [ fn | fn <- strict_field_names,
- not (fn `elem` field_names_used)
- ]
- where
- field_names_used = [ field_name | (field_name, _, _) <- rbinds ]
- strict_field_names = mapMaybe isStrict field_info
-
- isStrict (fl, MarkedStrict) = Just (fieldLabelName fl)
- isStrict _ = Nothing
-
- field_info = zip (dataConFieldLabels data_con)
- (dataConStrictMarks data_con)
-
missingFields rbinds data_con
- = [ fn | fn <- non_strict_field_names, not (fn `elem` field_names_used) ]
+ | null field_labels = ([], []) -- Not declared as a record;
+ -- But C{} is still valid
+ | otherwise
+ = (missing_strict_fields, other_missing_fields)
where
- field_names_used = [ field_name | (field_name, _, _) <- rbinds ]
-
- -- missing strict fields have already been flagged as
- -- being so, so leave them out here.
- non_strict_field_names = mapMaybe isn'tStrict field_info
-
- isn'tStrict (fl, MarkedStrict) = Nothing
- isn'tStrict (fl, _) = Just (fieldLabelName fl)
-
- field_info = zip (dataConFieldLabels data_con)
- (dataConStrictMarks data_con)
+ missing_strict_fields
+ = [ fl | (fl, str) <- field_info,
+ isMarkedStrict str,
+ not (fieldLabelName fl `elem` field_names_used)
+ ]
+ other_missing_fields
+ = [ fl | (fl, str) <- field_info,
+ not (isMarkedStrict str),
+ not (fieldLabelName fl `elem` field_names_used)
+ ]
+ field_names_used = [ field_name | (field_name, _, _) <- rbinds ]
+ field_labels = dataConFieldLabels data_con
+
+ field_info = zipEqual "missingFields"
+ field_labels
+ (drop (length ex_theta) (dataConStrictMarks data_con))
+ -- The 'drop' is because dataConStrictMarks
+ -- includes the existential dictionaries
+ (_, _, _, ex_theta, _, _) = dataConSig data_con
\end{code}
%************************************************************************
Mini-utils:
-\begin{code}
-pp_nest_hang :: String -> SDoc -> SDoc
-pp_nest_hang lbl stuff = nest 2 (hang (text lbl) 4 stuff)
-\end{code}
-
Boring and alphabetical:
\begin{code}
arithSeqCtxt expr
notSelector field
= hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
-missingStrictFieldCon :: Name -> Name -> SDoc
+missingStrictFieldCon :: Name -> FieldLabel -> SDoc
missingStrictFieldCon con field
= hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
ptext SLIT("does not have the required strict field"), quotes (ppr field)]
-missingFieldCon :: Name -> Name -> SDoc
+missingFieldCon :: Name -> FieldLabel -> SDoc
missingFieldCon con field
= hsep [ptext SLIT("Field") <+> quotes (ppr field),
ptext SLIT("is not initialised")]
where
u_var = getUniqSupplyVar down
-tcGetUniques :: Int -> NF_TcM [Unique]
-tcGetUniques n down env
+tcGetUniques :: NF_TcM [Unique]
+tcGetUniques down env
= do uniq_supply <- readIORef u_var
let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
- uniqs = uniqsFromSupply n uniq_s
+ uniqs = uniqsFromSupply uniq_s
writeIORef u_var new_uniq_supply
return uniqs
where
#include "HsVersions.h"
import HsSyn ( TyClDecl(..), ConDecl(..), ConDetails(..), BangType(..),
- getBangType, conDetailsTys
+ getBangType, getBangStrictness, conDetailsTys
)
import RnHsSyn ( RenamedTyClDecl, RenamedConDecl, RenamedContext )
import BasicTypes ( NewOrData(..), RecFlag, isRec )
)
import TcMonad
-import DataCon ( DataCon, mkDataCon, dataConFieldLabels, markedStrict,
- notMarkedStrict, markedUnboxed, dataConRepType
- )
+import DataCon ( DataCon, mkDataCon, dataConFieldLabels, dataConRepType )
import MkId ( mkDataConId, mkDataConWrapId, mkRecordSelId )
import FieldLabel
import Var ( TyVar )
arg_tyvars = tyVarsOfTypes arg_tys
in_arg_tys pred = not $ isEmptyVarSet $
tyVarsOfPred pred `intersectVarSet` arg_tyvars
-
-getBangStrictness (Banged _) = markedStrict
-getBangStrictness (Unbanged _) = notMarkedStrict
-getBangStrictness (Unpacked _) = markedUnboxed
\end{code}
where
datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys
-
--- This constructs the c_of datatype from a DataCon and a Type
--- The identity function at the moment.
-cOfConstr :: DataCon -> Type -> Type
-cOfConstr y z = z
-
-
----------------------------------------------------
-- Dealing with products
----------------------------------------------------
projects / ghc-hetmet.git / commitdiff