diff options
32 files changed, 294 insertions, 388 deletions
diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index 3a1bd476dd..293e0f1863 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -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 diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index dd6212b735..c5dd0e1d70 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -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], @@ -174,26 +169,6 @@ 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} diff --git a/ghc/compiler/basicTypes/Demand.lhs b/ghc/compiler/basicTypes/Demand.lhs index 546e3a2bbb..17d13dc162 100644 --- a/ghc/compiler/basicTypes/Demand.lhs +++ b/ghc/compiler/basicTypes/Demand.lhs @@ -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} + + diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index c59fefe256..8e496b3170 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -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 diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index dae32dfeb5..b639f2178f 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -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} diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs index a24a4c1996..218df9ee90 100644 --- a/ghc/compiler/basicTypes/UniqSupply.lhs +++ b/ghc/compiler/basicTypes/UniqSupply.lhs @@ -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} diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index feb4e8ed1c..86e6d600b6 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -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} diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index 90a3ead69f..ec86225e18 100644 --- a/ghc/compiler/coreSyn/Subst.lhs +++ b/ghc/compiler/coreSyn/Subst.lhs @@ -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 diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index a83a1f4a7b..717faad02c 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -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 diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 15e08a8eb9..12ea7df333 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -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} + %************************************************************************ %* * diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index a537ee8164..0ca118b3b8 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -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) 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) diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index d6901889f6..33ef7368ba 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -12,7 +12,7 @@ module HsDecls ( 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, @@ -32,6 +32,7 @@ import HsCore ( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo, ) import CoreSyn ( CoreRule(..) ) import BasicTypes ( NewOrData(..) ) +import Demand ( StrictnessMark(..) ) import CallConv ( CallConv, pprCallConv ) -- others: @@ -556,19 +557,14 @@ eq_fld env (ns1,bt1) (ns2, bt2) = ns1==ns2 && eq_btype env bt1 bt2 \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} @@ -592,9 +588,7 @@ ppr_con_details con (RecCon fields) 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} diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 7667b4517d..4671fc4ebb 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -207,13 +207,6 @@ data ModDetails \end{code} \begin{code} -emptyModDetails :: ModDetails -emptyModDetails - = ModDetails { md_types = emptyTypeEnv, - md_insts = [], - md_rules = [] - } - emptyModIface :: Module -> ModIface emptyModIface mod = ModIface { mi_module = mod, diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 45828c7630..49c1cb1404 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -34,7 +34,7 @@ import CmdLineOpts 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 ) @@ -202,20 +202,18 @@ ifaceTyCls (ATyCon tycon) so_far 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 diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index 5c4e6a47e4..47b0d16e19 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -42,7 +42,7 @@ import CallConv import OccName ( dataName, varName, tcClsName, occNameSpace, setOccNameSpace, occNameUserString ) import FastString ( unpackFS ) -import UniqFM ( UniqFM, listToUFM, lookupUFM ) +import UniqFM ( UniqFM, listToUFM ) import Outputable ----------------------------------------------------------------------------- @@ -68,7 +68,7 @@ mkVanillaCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDeta 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" diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index ca4fafbdd6..f83ce6f38a 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$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. @@ -25,6 +25,7 @@ import OccName ( UserFS, varName, tcName, dataName, tcClsName, tvName ) import SrcLoc ( SrcLoc ) import Module import CallConv +import Demand ( StrictnessMark(..) ) import CmdLineOpts ( opt_SccProfilingOn ) import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), NewOrData(..) ) import Panic @@ -574,9 +575,9 @@ varids0 :: { [RdrName] } -- 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 } @@ -597,18 +598,18 @@ context :: { RdrNameContext } 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 } @@ -618,8 +619,8 @@ fielddecl :: { ([RdrName],RdrNameBangType) } : 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 } diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 57695057cd..5e10b29e13 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -103,7 +103,8 @@ import Name ( Name, nameRdrName, nameUnique, nameOccName, 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 diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index e4bcf4b67f..4a942ead6b 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -42,6 +42,7 @@ import BasicTypes ( Fixity(..), FixityDirection(..), 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(..) ) @@ -477,9 +478,9 @@ constr : src_loc ex_stuff qdata_name batypes { mk_con_decl $3 $2 (VanillaCon -- 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 : { ([],[]) } @@ -490,18 +491,18 @@ batypes : { [] } | 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) } -------------------------------------------------------------------------- diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index 137e916192..33dacd7d73 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -546,29 +546,6 @@ renameSig (NoInlineSig v p src_loc) 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} - %************************************************************************ %* * diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index d402a4c214..8f536984b0 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -12,7 +12,6 @@ import {-# SOURCE #-} RnHiFiles import HsSyn import RdrHsSyn ( RdrNameIE ) -import RnHsSyn ( RenamedTyClDecl ) import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, mkRdrUnqual, mkRdrQual, lookupRdrEnv, foldRdrEnv ) @@ -39,11 +38,10 @@ import Module ( ModuleName, moduleName, mkVanillaModule, 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 @@ -458,9 +456,8 @@ newLocalsRn :: [(RdrName,SrcLoc)] 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 ] diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 4477e89df4..87f8953059 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -508,10 +508,10 @@ mkHiPath hi_boot_file locn 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. diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 0023a130c5..65fbfd50ee 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -488,17 +488,9 @@ rnField doc (names, ty) 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 diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index e128eea0b0..4fc7362155 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -716,7 +716,7 @@ mapLvl = mapUs \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 diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index 9978ab2671..19faf99852 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -283,10 +283,10 @@ getUniqueSmpl dflags env us sc = 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 @@ -751,6 +751,5 @@ newIds fs tys m dflags env@(SimplEnv {seSubst = subst}) 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} diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index e3dcba73c9..d28523f0b0 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -63,7 +63,6 @@ import TysPrim ( realWorldStatePrimTy ) import PrelInfo ( realWorldPrimId ) import OrdList import Maybes ( maybeToBool ) -import Util ( zipWithEqual ) import Outputable \end{code} @@ -1390,9 +1389,9 @@ prepareCaseAlts bndr (Just (tycon, inst_tys)) scrut_cons alts 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') @@ -1626,13 +1625,20 @@ mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs) thing_inside -- 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]) diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index b7640656d8..1bcf59bef6 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -308,7 +308,7 @@ mkWWargs fun_ty arity demands res_bot one_shots -- 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 @@ -421,7 +421,7 @@ mk_ww_str (arg : ds) -- 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 @@ -481,7 +481,7 @@ mkWWcpr body_ty ReturnsCPR | 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 @@ -491,7 +491,7 @@ mkWWcpr body_ty ReturnsCPR 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 diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index c0c5f78011..3cdbf52f29 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -74,7 +74,7 @@ import TysWiredIn ( isIntTy, isIntegerTy ) import PrelNames( fromIntegerName, fromRationalName ) -import Util ( thenCmp, zipWithEqual ) +import Util ( thenCmp ) import Bag import Outputable \end{code} @@ -310,8 +310,8 @@ newDictsAtLoc :: InstLoc -> 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 diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 3994e93952..43e833407c 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -40,7 +40,8 @@ import PrelInfo ( nO_METHOD_BINDING_ERROR_ID ) 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(..) ) @@ -152,7 +153,7 @@ tcClassDecl1 is_rec rec_env 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-}] @@ -561,9 +562,9 @@ mkDefMethRhs is_inst_decl clas inst_tys sel_id loc (DefMeth dm_id) 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)) @@ -578,7 +579,7 @@ mkDefMethRhs is_inst_decl clas inst_tys sel_id loc GenDefMeth -- 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 @@ -645,20 +646,18 @@ badMethodErr clas op = 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) diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 07c33745b0..006983ddf4 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -36,11 +36,12 @@ import TcType ( TcType, TcTauType, 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, @@ -62,7 +63,7 @@ import PrelNames ( cCallableClassName, thenMName, failMName, returnMName, ioTyConName ) import Outputable -import Maybes ( maybeToBool, mapMaybe ) +import Maybes ( maybeToBool ) import ListSetOps ( minusList ) import Util import CmdLineOpts @@ -400,14 +401,11 @@ tcMonoExpr expr@(RecordCon con_name rbinds) res_ty 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_` @@ -868,35 +866,32 @@ badFields rbinds data_con 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} %************************************************************************ @@ -946,11 +941,6 @@ tcLit lit res_ty 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 @@ -1013,12 +1003,12 @@ recordConCtxt expr = ptext SLIT("In the record construction:") <+> ppr 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")] diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index c0fb587abb..b6f0291cd0 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -544,11 +544,11 @@ tcGetUnique down env 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 diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index bde665527a..a0a00b040a 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -11,7 +11,7 @@ module TcTyDecls ( #include "HsVersions.h" import HsSyn ( TyClDecl(..), ConDecl(..), ConDetails(..), BangType(..), - getBangType, conDetailsTys + getBangType, getBangStrictness, conDetailsTys ) import RnHsSyn ( RenamedTyClDecl, RenamedConDecl, RenamedContext ) import BasicTypes ( NewOrData(..), RecFlag, isRec ) @@ -25,9 +25,7 @@ import TcEnv ( tcExtendTyVarEnv, ) 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 ) @@ -183,10 +181,6 @@ thinContext arg_tys ctxt 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} diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index 44fd27a757..537be155d4 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -340,13 +340,6 @@ mk_sum_stuff i tyvars datacons 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 ---------------------------------------------------- |