Commit b4775e5e authored by simonpj's avatar simonpj

[project @ 2001-05-18 08:46:18 by simonpj]

-----------------------------
	Get unbox-strict-fields right
	-----------------------------

The problem was that when a library was compiled *without* -funbox-strict-fields,
and the main program was compiled *with* that flag, we were wrongly treating
the fields of imported data types as unboxed.

To fix this I added an extra constructor to StrictnessMark to express whether
the "!" annotation came from an interface file (don't fiddle) or a source
file (decide whether to unbox).

On the way I tided things up:

* StrictnessMark moves to Demand.lhs, and doesn't have the extra DataCon
  fields that kept it in DataCon before.

* HsDecls.BangType has one constructor, not three, with a StrictnessMark field.

* DataCon keeps track of its strictness signature (dcRepStrictness), but not
  its "user strict marks" (which were never used)

* All the functions, like getUniquesDs, that used to take an Int saying how
  many uniques to allocate, now return an infinite list. This saves arguments
  and hassle.  But it involved touching quite a few files.

* rebuildConArgs takes a list of Uniques to use as its unique supply.  This
  means I could combine DsUtils.rebuildConArgs with MkId.rebuildConArgs
  (hooray; the main point of the previous change)


I also tidied up one or two error messages
parent 740b4461
......@@ -289,8 +289,8 @@ mapAndUnzipFlt f (x:xs)
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}
%************************************************************************
......@@ -474,7 +474,7 @@ doSimultaneously1 vertices
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
......
......@@ -18,9 +18,6 @@ module DataCon (
isExistentialDataCon, classDataCon,
splitProductType_maybe, splitProductType,
StrictnessMark(..), -- Representation visible to MkId only
markedStrict, notMarkedStrict, markedUnboxed, maybeMarkedUnboxed
) where
#include "HsVersions.h"
......@@ -40,14 +37,14 @@ import Name ( Name, NamedThing(..), nameUnique )
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}
......@@ -118,18 +115,16 @@ data DataCon
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],
......@@ -172,26 +167,6 @@ but the rep type is
Actually, the unboxed part isn't implemented yet!
%************************************************************************
%* *
\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}
......@@ -254,18 +229,23 @@ mkDataCon name arg_stricts fields
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)
......@@ -304,7 +284,7 @@ dataConFieldLabels :: DataCon -> [FieldLabel]
dataConFieldLabels = dcFields
dataConStrictMarks :: DataCon -> [StrictnessMark]
dataConStrictMarks = dcRealStricts
dataConStrictMarks = dcStrictMarks
-- Number of type-instantiation arguments
-- All the remaining arguments of the DataCon are (notionally)
......@@ -326,13 +306,7 @@ isNullaryDataCon con = dataConRepArity con == 0
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,
......@@ -449,23 +423,36 @@ splitProductType str ty
-- 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}
......@@ -17,6 +17,8 @@ module Demand(
noStrictnessInfo,
ppStrictnessInfo, seqStrictnessInfo,
isBottomingStrictness, appIsBottom,
StrictnessMark(..), isMarkedUnboxed, isMarkedStrict
) where
#include "HsVersions.h"
......@@ -207,3 +209,35 @@ ppStrictnessInfo NoStrictnessInfo = empty
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}
......@@ -98,8 +98,7 @@ import TysPrim ( statePrimTyCon )
import FieldLabel ( FieldLabel )
import SrcLoc ( SrcLoc )
import Outputable
import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques,
getNumBuiltinUniques )
import Unique ( Unique, mkBuiltinUnique )
infixl 1 `setIdUnfolding`,
`setIdArityInfo`,
......@@ -173,15 +172,11 @@ mkWorkerId uniq unwrkr ty
-- "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
......
......@@ -17,7 +17,7 @@ module MkId (
mkDictSelId,
mkDataConId, mkDataConWrapId,
mkRecordSelId,
mkRecordSelId, rebuildConArgs,
mkPrimOpId, mkCCallOpId,
-- And some particular Ids; see below for why they are wired in
......@@ -59,16 +59,17 @@ import PrimOp ( PrimOp(DataToTagOp, CCallOp),
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
)
......@@ -83,6 +84,7 @@ import FieldLabel ( mkFieldLabel, fieldLabelName,
firstFieldLabelTag, allFieldLabelTags, fieldLabelType
)
import CoreSyn
import Unique ( mkBuiltinUnique )
import Maybes
import PrelNames
import Maybe ( isJust )
......@@ -239,7 +241,7 @@ mkDataConWrapId data_con
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.
......@@ -286,15 +288,12 @@ mkDataConWrapId data_con
(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
......@@ -304,11 +303,12 @@ mkDataConWrapId data_con
| 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}
......@@ -451,12 +451,12 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
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)
......@@ -480,41 +480,42 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
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}
......
......@@ -66,7 +66,7 @@ mkSplitUniqSupply :: Char -> IO UniqSupply
splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
uniqFromSupply :: UniqSupply -> Unique
uniqsFromSupply :: Int -> UniqSupply -> [Unique]
uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite
\end{code}
\begin{code}
......@@ -94,13 +94,8 @@ splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
\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}
%************************************************************************
......@@ -157,9 +152,9 @@ getUniqueUs :: UniqSM Unique
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}
......
......@@ -41,7 +41,7 @@ module Unique (
mkPreludeMiscIdUnique, mkPreludeDataConUnique,
mkPreludeTyConUnique, mkPreludeClassUnique,
getNumBuiltinUniques, getBuiltinUniques, mkBuiltinUnique,
mkBuiltinUnique,
mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3
) where
......@@ -330,15 +330,5 @@ mkBuiltinUnique i = mkUnique 'B' i
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}
......@@ -665,14 +665,14 @@ subst_clone_id rec_subst subst@(Subst in_scope env) (old_id, uniq)
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
......
......@@ -14,7 +14,7 @@ module DsMonad (
newFailLocalDs,
getSrcLocDs, putSrcLocDs,
getModuleDs,
getUniqueDs,
getUniqueDs, getUniquesDs,
getDOptsDs,
dsLookupGlobalValue,
......@@ -152,8 +152,11 @@ newFailLocalDs ty dflags us genv loc mod warns
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
......@@ -166,16 +169,13 @@ duplicateLocalDs old_local 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
......
......@@ -41,12 +41,11 @@ import DsMonad
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
)
......@@ -298,10 +297,12 @@ mkCoAlgCaseMatchResult var match_alts
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)]
......@@ -310,39 +311,7 @@ mkCoAlgCaseMatchResult var match_alts
= 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}
%************************************************************************
%* *
......
......@@ -111,14 +111,14 @@ pp_context NoMatchContext msg rest_of_msg_fun
= 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)