diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs
index 029c7c73e9c9ea765ff595180f95562848d8aab5..6f6772c317958a78fced4ce3fe37bfe3c87ab58a 100644
--- a/ghc/compiler/absCSyn/AbsCUtils.lhs
+++ b/ghc/compiler/absCSyn/AbsCUtils.lhs
@@ -152,7 +152,7 @@ getAmodeRep (CVal _ kind) = kind
getAmodeRep (CAddr _) = PtrRep
getAmodeRep (CReg magic_id) = magicIdPrimRep magic_id
getAmodeRep (CTemp uniq kind) = kind
-getAmodeRep (CLbl label kind) = kind
+getAmodeRep (CLbl _ kind) = kind
getAmodeRep (CCharLike _) = PtrRep
getAmodeRep (CIntLike _) = PtrRep
getAmodeRep (CLit lit) = literalPrimRep lit
@@ -308,9 +308,9 @@ flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast descr)
CClosureInfoAndCode cl_info slow_heres fast_heres descr]
)
-flatAbsC (CCodeBlock label abs_C)
+flatAbsC (CCodeBlock lbl abs_C)
= flatAbsC abs_C `thenFlt` \ (absC_heres, absC_tops) ->
- returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock label absC_heres)
+ returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock lbl absC_heres)
flatAbsC (CRetDirect uniq slow_code srt liveness)
= flatAbsC slow_code `thenFlt` \ (heres, tops) ->
diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index f65ab5c6aa9cadc3754c62402c00ba9def7d6dfd..c5c91f165c5051160df28b4ac0a302cae146298e 100644
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -318,16 +318,16 @@ pprAbsC stmt@(CCallTypedef op@(CCallOp op_str is_asm may_gc cconv) results args)
let nvrs = grab_non_void_amodes results
in ASSERT (length nvrs <= 1) nvrs
-pprAbsC (CCodeBlock label abs_C) _
+pprAbsC (CCodeBlock lbl abs_C) _
= if not (maybeToBool(nonemptyAbsC abs_C)) then
- pprTrace "pprAbsC: curious empty code block for" (pprCLabel label) empty
+ pprTrace "pprAbsC: curious empty code block for" (pprCLabel lbl) empty
else
case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
vcat [
- hcat [text (if (externallyVisibleCLabel label)
+ hcat [text (if (externallyVisibleCLabel lbl)
then "FN_(" -- abbreviations to save on output
else "IFN_("),
- pprCLabel label, text ") {"],
+ pprCLabel lbl, text ") {"],
pp_exts, pp_temps,
@@ -498,18 +498,18 @@ pprAbsC stmt@(CRetDirect uniq code srt liveness) _
LvSmall _ -> SLIT("RET_SMALL")
LvLarge _ -> SLIT("RET_BIG")
-pprAbsC stmt@(CRetVector label amodes srt liveness) _
+pprAbsC stmt@(CRetVector lbl amodes srt liveness) _
= case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
vcat [
pp_exts,
hcat [
ptext SLIT("VEC_INFO_") <> int size,
lparen,
- pprCLabel label, comma,
+ pprCLabel lbl, comma,
pp_liveness liveness, comma, -- bitmap liveness mask
pp_srt_info srt, -- SRT
ptext type_str, comma,
- ppLocalness label, comma
+ ppLocalness lbl, comma
],
nest 2 (sep (punctuate comma (map ppr_item amodes))),
text ");"
@@ -530,8 +530,8 @@ pprAbsC (CCostCentreStackDecl ccs) _ = pprCostCentreStackDecl ccs
\end{code}
\begin{code}
-ppLocalness label
- = if (externallyVisibleCLabel label)
+ppLocalness lbl
+ = if (externallyVisibleCLabel lbl)
then empty
else ptext SLIT("static ")
@@ -1137,7 +1137,7 @@ ppr_amode (CReg magic_id) = pprMagicId magic_id
ppr_amode (CTemp uniq kind) = char '_' <> pprUnique uniq <> char '_'
-ppr_amode (CLbl label kind) = pprCLabelAddr label
+ppr_amode (CLbl lbl kind) = pprCLabelAddr lbl
ppr_amode (CCharLike ch)
= hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode ch, rparen ]
@@ -1409,11 +1409,11 @@ tempSeenTE uniq env@(seen_uniqs, seen_labels)
False)
labelSeenTE :: CLabel -> TeM Bool
-labelSeenTE label env@(seen_uniqs, seen_labels)
- = if (label `elementOfCLabelSet` seen_labels)
+labelSeenTE lbl env@(seen_uniqs, seen_labels)
+ = if (lbl `elementOfCLabelSet` seen_labels)
then (env, True)
else ((seen_uniqs,
- addToCLabelSet seen_labels label),
+ addToCLabelSet seen_labels lbl),
False)
\end{code}
@@ -1466,7 +1466,7 @@ ppr_decls_AbsC (CSwitch discrim alts deflt)
where
ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC
-ppr_decls_AbsC (CCodeBlock label absC)
+ppr_decls_AbsC (CCodeBlock lbl absC)
= ppr_decls_AbsC absC
ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre)
@@ -1550,13 +1550,13 @@ ppr_decls_Amode (CTemp uniq kind)
returnTE
(if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
-ppr_decls_Amode (CLbl label VoidRep)
+ppr_decls_Amode (CLbl lbl VoidRep)
= returnTE (Nothing, Nothing)
-ppr_decls_Amode (CLbl label kind)
- = labelSeenTE label `thenTE` \ label_seen ->
+ppr_decls_Amode (CLbl lbl kind)
+ = labelSeenTE lbl `thenTE` \ label_seen ->
returnTE (Nothing,
- if label_seen then Nothing else Just (pprExternDecl False{-not in an SRT decl-} label))
+ if label_seen then Nothing else Just (pprExternDecl False{-not in an SRT decl-} lbl))
ppr_decls_Amode (CMacroExpr _ _ amodes)
= ppr_decls_Amodes amodes
diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs
index 2c5f7b4cbbe32b1dbc40a9edfab813e03c335951..f8aa66a2ebe06b79ed8e93ea4e33082e76505426 100644
--- a/ghc/compiler/basicTypes/DataCon.lhs
+++ b/ghc/compiler/basicTypes/DataCon.lhs
@@ -9,12 +9,12 @@ module DataCon (
ConTag, fIRST_TAG,
mkDataCon,
dataConType, dataConSig, dataConName, dataConTag,
- dataConOrigArgTys, dataConArgTys, dataConTyCon,
+ dataConArgTys, dataConTyCon,
dataConRawArgTys, dataConAllRawArgTys,
dataConFieldLabels, dataConStrictMarks, dataConSourceArity,
dataConNumFields, dataConNumInstArgs, dataConId, dataConRepStrictness,
isNullaryDataCon, isTupleCon, isUnboxedTupleCon,
- isExistentialDataCon,
+ isExistentialDataCon, splitProductType_maybe,
StrictnessMark(..), -- Representation visible to MkId only
markedStrict, notMarkedStrict, markedUnboxed, maybeMarkedUnboxed
@@ -32,10 +32,10 @@ import Type ( Type, ThetaType, TauType,
splitAlgTyConApp_maybe
)
import PprType
-import TyCon ( TyCon, tyConDataCons, isDataTyCon,
+import TyCon ( TyCon, tyConDataCons, isDataTyCon, isProductTyCon,
isTupleTyCon, isUnboxedTupleTyCon )
import Class ( classTyCon )
-import Name ( Name, NamedThing(..), nameUnique, isLocallyDefinedName )
+import Name ( Name, NamedThing(..), nameUnique, isLocallyDefined )
import Var ( TyVar, Id )
import FieldLabel ( FieldLabel )
import BasicTypes ( Arity )
@@ -44,6 +44,7 @@ import Outputable
import Unique ( Unique, Uniquable(..) )
import CmdLineOpts ( opt_UnboxStrictFields )
import UniqSet
+import Maybes ( maybeToBool )
import Maybe
import Util ( assoc )
\end{code}
@@ -246,76 +247,8 @@ mk_dict_strict_mark (clas,tys)
-- Don't mark newtype things as strict!
isDataTyCon (classTyCon clas) = MarkedStrict
| otherwise = NotMarkedStrict
-
--- We attempt to unbox/unpack a strict field when either:
--- (i) The tycon is imported, and the field is marked '! !', or
--- (ii) The tycon is defined in this module, the field is marked '!',
--- and the -funbox-strict-fields flag is on.
---
--- This ensures that if we compile some modules with -funbox-strict-fields and
--- 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 NotMarkedStrict ty
- = (NotMarkedStrict, [ty])
-unbox_strict_arg_ty tycon MarkedStrict ty
- | not opt_UnboxStrictFields
- || not (isLocallyDefinedName (getName tycon)) = (MarkedStrict, [ty])
-unbox_strict_arg_ty tycon marked_unboxed ty
- -- MarkedUnboxed || (MarkedStrict && opt_UnboxStrictFields && not imported)
- = case splitAlgTyConApp_maybe ty of
- Just (tycon,_,[])
- -> panic (showSDoc (hcat [
- text "unbox_strict_arg_ty: constructors for ",
- ppr tycon,
- text " not available."
- ]))
- Just (tycon,ty_args,[con])
- -> case maybe_unpack_fields emptyUniqSet
- (zip (dataConOrigArgTys con ty_args)
- (dcUserStricts con))
- of
- Nothing -> (MarkedStrict, [ty])
- Just tys -> (MarkedUnboxed con tys, tys)
- _ -> (MarkedStrict, [ty])
-
--- bail out if we encounter the same tycon twice. This avoids problems like
---
--- data A = !B
--- data B = !A
---
--- where no useful unpacking can be done.
-
-maybe_unpack_field :: UniqSet TyCon -> Type -> StrictnessMark -> Maybe [Type]
-maybe_unpack_field set ty NotMarkedStrict
- = Just [ty]
-maybe_unpack_field set ty MarkedStrict | not opt_UnboxStrictFields
- = Just [ty]
-maybe_unpack_field set ty strict
- = case splitAlgTyConApp_maybe ty of
- Just (tycon,ty_args,[con])
- -- loop breaker
- | tycon `elementOfUniqSet` set -> Nothing
- -- don't unpack constructors with existential tyvars
- | not (null ex_tyvars) -> Nothing
- -- ok, let's do it
- | otherwise ->
- let set' = addOneToUniqSet set tycon in
- maybe_unpack_fields set'
- (zip (dataConOrigArgTys con ty_args)
- (dcUserStricts con))
- where (_, _, ex_tyvars, _, _, _) = dataConSig con
- _ -> Just [ty]
-
-maybe_unpack_fields :: UniqSet TyCon -> [(Type,StrictnessMark)] -> Maybe [Type]
-maybe_unpack_fields set tys
- | all isJust unpacked_fields = Just (concat (catMaybes unpacked_fields))
- | otherwise = Nothing
- where unpacked_fields = map (\(ty,str) -> maybe_unpack_field set ty str) tys
\end{code}
-
\begin{code}
dataConName :: DataCon -> Name
dataConName = dcName
@@ -363,7 +296,7 @@ dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta,
dcOrigArgTys = arg_tys, dcTyCon = tycon})
= (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon)
-dataConArgTys, dataConOrigArgTys :: DataCon
+dataConArgTys :: DataCon
-> [Type] -- Instantiated at these types
-- NB: these INCLUDE the existentially quantified arg types
-> [Type] -- Needs arguments of these types
@@ -374,11 +307,6 @@ dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars,
dcExTyVars = ex_tyvars, dcExTheta = ex_theta}) inst_tys
= map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys))
([mkDictTy cls tys | (cls,tys) <- ex_theta] ++ arg_tys)
-
-dataConOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars,
- dcExTyVars = ex_tyvars, dcExTheta = ex_theta}) inst_tys
- = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys))
- ([mkDictTy cls tys | (cls,tys) <- ex_theta] ++ arg_tys)
\end{code}
These two functions get the real argument types of the constructor,
@@ -421,3 +349,72 @@ isUnboxedTupleCon (MkData {dcTyCon = tc}) = isUnboxedTupleTyCon tc
isExistentialDataCon :: DataCon -> Bool
isExistentialDataCon (MkData {dcExTyVars = tvs}) = not (null tvs)
\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Splitting products}
+%* *
+%************************************************************************
+
+\begin{code}
+splitProductType_maybe
+ :: Type -- A product type, perhaps
+ -> Maybe (TyCon, -- The type constructor
+ [Type], -- Type args of the tycon
+ DataCon, -- The data constructor
+ [Type]) -- Its *representation* arg types
+
+ -- Returns (Just ...) for any
+ -- single-constructor
+ -- non-recursive type
+ -- not existentially quantified
+ -- type whether a data type or a new type
+ --
+ -- Rejecing existentials is conservative. Maybe some things
+ -- could be made to work with them, but I'm not going to sweat
+ -- it through till someone finds it's important.
+
+splitProductType_maybe ty
+ = case splitAlgTyConApp_maybe ty of
+ Just (tycon,ty_args,[data_con])
+ | isProductTyCon tycon && -- Checks for non-recursive
+ not (isExistentialDataCon data_con)
+ -> Just (tycon, ty_args, data_con, data_con_arg_tys)
+ where
+ data_con_arg_tys = map (substTy (mkTyVarSubst (dcTyVars data_con) ty_args))
+ (dcRepArgTys data_con)
+ other -> Nothing
+
+
+-- We attempt to unbox/unpack a strict field when either:
+-- (i) The tycon is imported, and the field is marked '! !', or
+-- (ii) The tycon is defined in this module, the field is marked '!',
+-- and the -funbox-strict-fields flag is on.
+--
+-- This ensures that if we compile some modules with -funbox-strict-fields and
+-- 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
+ MarkedStrict -> opt_UnboxStrictFields &&
+ isLocallyDefined tycon &&
+ maybeToBool maybe_product &&
+ isDataTyCon arg_tycon
+ -- We can't look through newtypes in arguments (yet)
+ = (MarkedUnboxed con arg_tys, arg_tys)
+
+ | otherwise
+ = (strict_mark, [ty])
+
+ where
+ maybe_product = splitProductType_maybe ty
+ Just (arg_tycon, _, con, arg_tys) = maybe_product
+\end{code}
+
+
diff --git a/ghc/compiler/basicTypes/Demand.lhs b/ghc/compiler/basicTypes/Demand.lhs
index 7a4dbfef51c21b9e194e5a19bdb346b48f4556b4..cb45ddcd4ae558dd67b8ed90783a2d97bee03b58 100644
--- a/ghc/compiler/basicTypes/Demand.lhs
+++ b/ghc/compiler/basicTypes/Demand.lhs
@@ -10,7 +10,7 @@ module Demand(
wwLazy, wwStrict, wwUnpackData, wwUnpackNew, wwPrim, wwEnum,
isStrict, isLazy, isPrim,
- pprDemands
+ pprDemands, seqDemand, seqDemands
) where
#include "HsVersions.h"
@@ -63,6 +63,14 @@ wwUnpackData xs = WwUnpack DataType False xs
wwUnpackNew x = WwUnpack NewType False [x]
wwPrim = WwPrim
wwEnum = WwEnum
+
+seqDemand :: Demand -> ()
+seqDemand (WwLazy a) = a `seq` ()
+seqDemand (WwUnpack nd b ds) = nd `seq` b `seq` seqDemands ds
+seqDemand other = ()
+
+seqDemands [] = ()
+seqDemands (d:ds) = seqDemand d `seq` seqDemands ds
\end{code}
diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index aa086a19e534243d7fc052b05ba3428e5ddb7a3b..25ff7b53e4f48cab5b2a33ffa00cc2e0b8fb8a12 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -18,7 +18,7 @@ module Id (
-- Modifying an Id
setIdName, setIdUnique, setIdType, setIdNoDiscard,
- setIdInfo, modifyIdInfo, maybeModifyIdInfo,
+ setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
-- Predicates
omitIfaceSigForId,
@@ -70,11 +70,11 @@ import Var ( Id, DictId,
isId, mkIdVar,
idName, idType, idUnique, idInfo,
setIdName, setVarType, setIdUnique,
- setIdInfo, modifyIdInfo, maybeModifyIdInfo,
+ setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
externallyVisibleId
)
import VarSet
-import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars )
+import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars, seqType )
import IdInfo
import Demand ( Demand, isStrict, wwLazy )
import Name ( Name, OccName,
@@ -170,7 +170,7 @@ idFreeTyVars id = tyVarsOfType (idType id)
setIdType :: Id -> Type -> Id
-- Add free tyvar info to the type
-setIdType id ty = setVarType id (addFreeTyVars ty)
+setIdType id ty = seqType ty `seq` setVarType id (addFreeTyVars ty)
idPrimRep :: Id -> PrimRep
idPrimRep id = typePrimRep (idType id)
diff --git a/ghc/compiler/basicTypes/IdInfo.hi-boot b/ghc/compiler/basicTypes/IdInfo.hi-boot
index d57e7be36f0b9b1dd857db890e83f2a6a52be5b6..f88c4f6fefa0085699ae6e938012e15829d75c69 100644
--- a/ghc/compiler/basicTypes/IdInfo.hi-boot
+++ b/ghc/compiler/basicTypes/IdInfo.hi-boot
@@ -1,5 +1,6 @@
_interface_ IdInfo 1
_exports_
-IdInfo IdInfo ;
+IdInfo IdInfo seqIdInfo ;
_declarations_
1 data IdInfo ;
+1 seqIdInfo _:_ IdInfo -> PrelBase.() ;;
diff --git a/ghc/compiler/basicTypes/IdInfo.hi-boot-5 b/ghc/compiler/basicTypes/IdInfo.hi-boot-5
index 5c76c93b8f747c807c4de2a3a58bd53ca414a533..7e3e942f024f784b351b1c8ba51a9f25c20dbedd 100644
--- a/ghc/compiler/basicTypes/IdInfo.hi-boot-5
+++ b/ghc/compiler/basicTypes/IdInfo.hi-boot-5
@@ -1,3 +1,5 @@
__interface IdInfo 1 0 where
-__export IdInfo IdInfo ;
+__export IdInfo IdInfo seqIdInfo ;
1 data IdInfo ;
+1 seqIdInfo :: IdInfo -> PrelBase.Z0T ;
+
diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index 2c36363b4e0de97ad9b4c1c10a903a3b3b87abd3..52a4ad5b07267d463256f1d41c3baf56f721b130 100644
--- a/ghc/compiler/basicTypes/IdInfo.lhs
+++ b/ghc/compiler/basicTypes/IdInfo.lhs
@@ -10,7 +10,7 @@ Haskell. [WDP 94/11])
module IdInfo (
IdInfo, -- Abstract
- vanillaIdInfo, mkIdInfo,
+ vanillaIdInfo, mkIdInfo, seqIdInfo, megaSeqIdInfo,
-- Flavour
IdFlavour(..), flavourInfo,
@@ -57,7 +57,7 @@ module IdInfo (
CprInfo(..), cprInfo, setCprInfo, ppCprInfo, noCprInfo,
-- Zapping
- zapLamIdInfo, zapFragileIdInfo,
+ zapLamIdInfo, zapFragileIdInfo, zapIdInfoForStg,
-- Lambda-bound variable info
LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo
@@ -66,13 +66,13 @@ module IdInfo (
#include "HsVersions.h"
-import {-# SOURCE #-} CoreUnfold ( Unfolding, noUnfolding, hasUnfolding )
-import {-# SOURCE #-} CoreSyn ( CoreExpr, CoreRules, emptyCoreRules, isEmptyCoreRules )
+import {-# SOURCE #-} CoreUnfold ( Unfolding, noUnfolding, hasUnfolding, seqUnfolding )
+import {-# SOURCE #-} CoreSyn ( CoreExpr, CoreRules, emptyCoreRules, isEmptyCoreRules, seqRules )
import {-# SOURCE #-} Const ( Con )
import Var ( Id )
import FieldLabel ( FieldLabel )
-import Demand ( Demand, isStrict, isLazy, wwLazy, pprDemands )
+import Demand ( Demand, isStrict, isLazy, wwLazy, pprDemands, seqDemand, seqDemands )
import Type ( UsageAnn )
import Outputable
import Maybe ( isJust )
@@ -121,21 +121,47 @@ data IdInfo
cafInfo :: CafInfo,
cprInfo :: CprInfo, -- Function always constructs a product result
lbvarInfo :: LBVarInfo, -- Info about a lambda-bound variable
- inlinePragInfo :: !InlinePragInfo -- Inline pragmas
+ inlinePragInfo :: InlinePragInfo -- Inline pragmas
}
+
+seqIdInfo :: IdInfo -> ()
+seqIdInfo (IdInfo {}) = ()
+
+megaSeqIdInfo :: IdInfo -> ()
+megaSeqIdInfo info
+ = seqFlavour (flavourInfo info) `seq`
+ seqArity (arityInfo info) `seq`
+ seqDemand (demandInfo info) `seq`
+ seqRules (specInfo info) `seq`
+ seqStrictness (strictnessInfo info) `seq`
+ seqWorker (workerInfo info) `seq`
+
+-- seqUnfolding (unfoldingInfo info) `seq`
+-- Omitting this improves runtimes a little, presumably because
+-- some unfoldings are not calculated at all
+
+ seqCaf (cafInfo info) `seq`
+ seqCpr (cprInfo info) `seq`
+ seqLBVar (lbvarInfo info) `seq`
+ seqInlinePrag (inlinePragInfo info)
\end{code}
Setters
\begin{code}
+setWorkerInfo info wk = wk `seq` info { workerInfo = wk }
+setSpecInfo info sp = sp `seq` info { specInfo = sp }
+setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr }
+setStrictnessInfo info st = st `seq` info { strictnessInfo = st }
+ -- Try to avoid spack leaks by seq'ing
+
+setUnfoldingInfo info uf = info { unfoldingInfo = uf }
+ -- We do *not* seq on the unfolding info, For some reason, doing so
+ -- actually increases residency significantly.
+
setUpdateInfo info ud = info { updateInfo = ud }
setDemandInfo info dd = info { demandInfo = dd }
-setStrictnessInfo info st = info { strictnessInfo = st }
-setWorkerInfo info wk = info { workerInfo = wk }
-setSpecInfo info sp = info { specInfo = sp }
setArityInfo info ar = info { arityInfo = ar }
-setInlinePragInfo info pr = info { inlinePragInfo = pr }
-setUnfoldingInfo info uf = info { unfoldingInfo = uf }
setCafInfo info cf = info { cafInfo = cf }
setCprInfo info cp = info { cprInfo = cp }
setLBVarInfo info lb = info { lbvarInfo = lb }
@@ -229,6 +255,9 @@ ppFlavourInfo (ConstantId _) = ptext SLIT("[Constr]")
ppFlavourInfo (RecordSelId _) = ptext SLIT("[RecSel]")
ppFlavourInfo SpecPragmaId = ptext SLIT("[SpecPrag]")
ppFlavourInfo NoDiscardId = ptext SLIT("[NoDiscard]")
+
+seqFlavour :: IdFlavour -> ()
+seqFlavour f = f `seq` ()
\end{code}
The @SpecPragmaId@ exists only to make Ids that are
@@ -258,6 +287,9 @@ data ArityInfo
| ArityExactly Int -- Arity is exactly this
| ArityAtLeast Int -- Arity is this or greater
+seqArity :: ArityInfo -> ()
+seqArity a = arityLowerBound a `seq` ()
+
exactArity = ArityExactly
atLeastArity = ArityAtLeast
unknownArity = UnknownArity
@@ -307,6 +339,12 @@ data InlinePragInfo
| IMustBeINLINEd -- Absolutely must inline; used for PrimOps and
-- constructors only.
+seqInlinePrag :: InlinePragInfo -> ()
+seqInlinePrag (ICanSafelyBeINLINEd occ alts)
+ = occ `seq` alts `seq` ()
+seqInlinePrag other
+ = ()
+
instance Outputable InlinePragInfo where
ppr NoInlinePragInfo = empty
ppr IMustBeINLINEd = ptext SLIT("__UU")
@@ -367,6 +405,10 @@ data StrictnessInfo
-- BUT NB: f = \x y. error "urk"
-- will have info SI [SS] True
-- but still (f) and (f 2) are not bot; only (f 3 2) is bot
+
+seqStrictness :: StrictnessInfo -> ()
+seqStrictness (StrictnessInfo ds b) = b `seq` seqDemands ds
+seqStrictness other = ()
\end{code}
\begin{code}
@@ -414,6 +456,10 @@ mkWorkerInfo :: Id -> WorkerInfo
mkWorkerInfo wk_id = Just wk_id
-}
+seqWorker :: WorkerInfo -> ()
+seqWorker (Just id) = id `seq` ()
+seqWorker Nothing = ()
+
ppWorkerInfo Nothing = empty
ppWorkerInfo (Just wk_id) = ptext SLIT("__P") <+> ppr wk_id
@@ -480,6 +526,8 @@ data CafInfo
-- | OneCafRef Id
+seqCaf c = c `seq` ()
+
ppCafInfo NoCafRefs = ptext SLIT("__C")
ppCafInfo MayHaveCafRefs = empty
\end{code}
@@ -569,6 +617,13 @@ zapLamIdInfo info@(IdInfo {inlinePragInfo = inline_prag, demandInfo = demand})
other -> inline_prag
\end{code}
+\begin{code}
+zapIdInfoForStg :: IdInfo -> IdInfo
+ -- Return only the info needed for STG stuff
+ -- Namely, nothing, I think
+zapIdInfoForStg info = vanillaIdInfo
+\end{code}
+
%************************************************************************
%* *
@@ -616,6 +671,13 @@ data CprInfo
\end{code}
\begin{code}
+seqCpr :: CprInfo -> ()
+seqCpr (CPRInfo cs) = seqCprs cs
+seqCpr NoCPRInfo = ()
+
+seqCprs [] = ()
+seqCprs (c:cs) = seqCpr c `seq` seqCprs cs
+
noCprInfo = NoCPRInfo
@@ -658,6 +720,8 @@ data LBVarInfo
-- HACK ALERT! placing this info here is a short-term hack,
-- but it minimises changes to the rest of the compiler.
-- Hack agreed by SLPJ/KSW 1999-04.
+
+seqLBVar l = l `seq` ()
\end{code}
\begin{code}
diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs
index 4d5be70d52ceeb961dc60b179aeebb06d4b6b22f..d80eab60a9157f57b0024d005e552e7c0459887e 100644
--- a/ghc/compiler/basicTypes/Var.lhs
+++ b/ghc/compiler/basicTypes/Var.lhs
@@ -1,4 +1,4 @@
-%
+s%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section{@Vars@: Variables}
@@ -26,14 +26,14 @@ module Var (
-- Ids
Id, DictId,
idName, idType, idUnique, idInfo, modifyIdInfo, maybeModifyIdInfo,
- setIdName, setIdUnique, setIdInfo,
+ setIdName, setIdUnique, setIdInfo, lazySetIdInfo,
mkIdVar, isId, externallyVisibleId
) where
#include "HsVersions.h"
import {-# SOURCE #-} Type( Type, Kind )
-import {-# SOURCE #-} IdInfo( IdInfo )
+import {-# SOURCE #-} IdInfo( IdInfo, seqIdInfo )
import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey )
import Name ( Name, OccName, NamedThing(..),
@@ -118,8 +118,9 @@ varUnique :: Var -> Unique
varUnique (Var {realUnique = uniq}) = mkUniqueGrimily uniq
setVarUnique :: Var -> Unique -> Var
-setVarUnique var uniq = var {realUnique = getKey uniq,
- varName = setNameUnique (varName var) uniq}
+setVarUnique var@(Var {varName = name}) uniq
+ = var {realUnique = getKey uniq,
+ varName = setNameUnique name uniq}
setVarName :: Var -> Name -> Var
setVarName var new_name
@@ -266,11 +267,18 @@ setIdUnique = setVarUnique
setIdName :: Id -> Name -> Id
setIdName = setVarName
+lazySetIdInfo :: Id -> IdInfo -> Id
+lazySetIdInfo var info = var {varInfo = info}
+
setIdInfo :: Id -> IdInfo -> Id
-setIdInfo var info = var {varInfo = info}
+setIdInfo var info = seqIdInfo info `seq` var {varInfo = info}
+ -- Try to avoid spack leaks by seq'ing
modifyIdInfo :: (IdInfo -> IdInfo) -> Id -> Id
-modifyIdInfo fn var@(Var {varInfo = info}) = var {varInfo = fn info}
+modifyIdInfo fn var@(Var {varInfo = info})
+ = seqIdInfo new_info `seq` var {varInfo = new_info}
+ where
+ new_info = fn info
-- maybeModifyIdInfo tries to avoid unnecesary thrashing
maybeModifyIdInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id
diff --git a/ghc/compiler/basicTypes/VarSet.lhs b/ghc/compiler/basicTypes/VarSet.lhs
index 277c5d3c4e819cf72cc50d5e57bf8928b5850c69..18579d32b86876b7bb593945d95f12f4b5f287b4 100644
--- a/ghc/compiler/basicTypes/VarSet.lhs
+++ b/ghc/compiler/basicTypes/VarSet.lhs
@@ -13,7 +13,7 @@ module VarSet (
intersectVarSet, intersectsVarSet,
isEmptyVarSet, delVarSet, delVarSetByKey,
minusVarSet, foldVarSet, filterVarSet,
- lookupVarSet, mapVarSet,
+ lookupVarSet, mapVarSet, sizeVarSet, seqVarSet,
uniqAway
) where
@@ -58,6 +58,7 @@ lookupVarSet :: VarSet -> Var -> Maybe Var
-- Returns the set element, which may be
-- (==) to the argument, but not the same as
mapVarSet :: (Var -> Var) -> VarSet -> VarSet
+sizeVarSet :: VarSet -> Int
filterVarSet :: (Var -> Bool) -> VarSet -> VarSet
subVarSet :: VarSet -> VarSet -> Bool
@@ -79,11 +80,17 @@ mkVarSet = mkUniqSet
foldVarSet = foldUniqSet
lookupVarSet = lookupUniqSet
mapVarSet = mapUniqSet
+sizeVarSet = sizeUniqSet
filterVarSet = filterUniqSet
a `subVarSet` b = isEmptyVarSet (a `minusVarSet` b)
delVarSetByKey = delFromUFM_Directly -- Can't be bothered to add this to UniqSet
\end{code}
+\begin{code}
+seqVarSet :: VarSet -> ()
+seqVarSet s = sizeVarSet s `seq` ()
+\end{code}
+
\begin{code}
uniqAway :: VarSet -> Var -> Var
-- Give the Var a new unique, different to any in the VarSet
diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index e04a4c29439e09f5e9a234f3df96aca7524b27ae..26c7e51e442eab287f9e35be25f37c86957da036 100644
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.33 1999/06/24 13:04:17 simonmar Exp $
+% $Id: CgClosure.lhs,v 1.34 1999/07/14 14:40:28 simonpj Exp $
%
\section[CgClosure]{Code generation for closures}
@@ -538,7 +538,7 @@ argSatisfactionCheck closure_info
\begin{code}
thunkWrapper:: ClosureInfo -> CLabel -> Code -> Code
-thunkWrapper closure_info label thunk_code
+thunkWrapper closure_info lbl thunk_code
= -- Stack and heap overflow checks
nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
@@ -554,7 +554,7 @@ thunkWrapper closure_info label thunk_code
else absC AbsCNop) `thenC`
-- stack and/or heap checks
- thunkChecks label node_points (
+ thunkChecks lbl node_points (
-- Overwrite with black hole if necessary
blackHoleIt closure_info node_points `thenC`
diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index 95d411808dff25a9cb8a09a0a892f1da5b5bc430..fb9f014e4fae03348ba22c04ec7a4c35a11974ff 100644
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -12,7 +12,7 @@ module CoreLint (
#include "HsVersions.h"
-import IO ( hPutStr, stderr )
+import IO ( hPutStr, hPutStrLn, stderr )
import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug )
import CoreSyn
@@ -60,7 +60,7 @@ and do Core Lint when necessary.
beginPass :: String -> IO ()
beginPass pass_name
| opt_D_show_passes
- = hPutStr stderr ("*** " ++ pass_name ++ "\n")
+ = hPutStrLn stderr ("*** " ++ pass_name)
| otherwise
= return ()
@@ -68,6 +68,13 @@ beginPass pass_name
endPass :: String -> Bool -> [CoreBind] -> IO [CoreBind]
endPass pass_name dump_flag binds
= do
+ -- Report result size if required
+ -- This has the side effect of forcing the intermediate to be evaluated
+ if opt_D_show_passes then
+ hPutStrLn stderr (" Result size = " ++ show (coreBindsSize binds))
+ else
+ return ()
+
-- Report verbosely, if required
dumpIfSet dump_flag pass_name
(pprCoreBindings binds)
diff --git a/ghc/compiler/coreSyn/CoreSyn.hi-boot b/ghc/compiler/coreSyn/CoreSyn.hi-boot
index f8ae27cbb96d825f2e1a1d1c5107eb4b6a812eb2..3ea40f47d992d517a3045b8a3575383078aff93a 100644
--- a/ghc/compiler/coreSyn/CoreSyn.hi-boot
+++ b/ghc/compiler/coreSyn/CoreSyn.hi-boot
@@ -1,6 +1,6 @@
_interface_ CoreSyn 1
_exports_
-CoreSyn CoreExpr CoreRule CoreRules emptyCoreRules isEmptyCoreRules ;
+CoreSyn CoreExpr CoreRule CoreRules emptyCoreRules isEmptyCoreRules seqRules ;
_declarations_
-- Needed by IdInfo
@@ -10,4 +10,5 @@ _declarations_
1 data CoreRule ;
1 type CoreRules = [CoreRule] ;
1 emptyCoreRules _:_ CoreRules ;;
+1 seqRules _:_ CoreRules -> PrelBase.() ;;
1 isEmptyCoreRules _:_ CoreRules -> PrelBase.Bool ;;
diff --git a/ghc/compiler/coreSyn/CoreSyn.hi-boot-5 b/ghc/compiler/coreSyn/CoreSyn.hi-boot-5
index 58df923d39a9b1885577a107a6fafe02cdc8e24a..d8ad7ffe698030d95aed4a7203597f3f9630055c 100644
--- a/ghc/compiler/coreSyn/CoreSyn.hi-boot-5
+++ b/ghc/compiler/coreSyn/CoreSyn.hi-boot-5
@@ -1,5 +1,5 @@
__interface CoreSyn 1 0 where
-__export CoreSyn CoreExpr CoreRules CoreRule emptyCoreRules isEmptyCoreRules ;
+__export CoreSyn CoreExpr CoreRules CoreRule emptyCoreRules isEmptyCoreRules seqRules ;
-- Needed by IdInfo
1 type CoreExpr = Expr Var.IdOrTyVar;
@@ -8,4 +8,5 @@ __export CoreSyn CoreExpr CoreRules CoreRule emptyCoreRules isEmptyCoreRules ;
1 data CoreRule ;
1 type CoreRules = [CoreRule] ;
1 emptyCoreRules :: CoreRules ;
+1 seqRules :: CoreRules -> PrelBase.Z0T ;
1 isEmptyCoreRules :: CoreRules -> PrelBase.Bool ;
diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index e59fec1b7c53168cf023a03f592e56329f71db3d..c1eb1f060daed67d227ccd071443cec3f4856130 100644
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -22,6 +22,12 @@ module CoreSyn (
isValArg, isTypeArg, valArgCount, valBndrCount,
+ -- Seq stuff
+ seqRules, seqExpr, seqExprs,
+
+ -- Size
+ coreBindsSize,
+
-- Annotated expressions
AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, deAnnotate,
@@ -37,9 +43,9 @@ import TysWiredIn ( boolTy, stringTy, nilDataCon )
import CostCentre ( CostCentre, isDupdCC, noCostCentre )
import Var ( Var, Id, TyVar, IdOrTyVar, isTyVar, isId, idType )
import VarEnv
-import Id ( mkWildId, getInlinePragma )
-import Type ( Type, UsageAnn, mkTyVarTy, isUnLiftedType )
-import IdInfo ( InlinePragInfo(..) )
+import Id ( mkWildId, getInlinePragma, idInfo )
+import Type ( Type, UsageAnn, mkTyVarTy, isUnLiftedType, seqType )
+import IdInfo ( InlinePragInfo(..), megaSeqIdInfo )
import Const ( Con(..), DataCon, Literal(NoRepStr), PrimOp )
import TysWiredIn ( trueDataCon, falseDataCon )
import VarSet
@@ -382,6 +388,85 @@ valArgCount (other : args) = 1 + valArgCount args
\end{code}
+%************************************************************************
+%* *
+\subsection{Seq stuff}
+%* *
+%************************************************************************
+
+\begin{code}
+seqExpr :: CoreExpr -> ()
+seqExpr (Var v) = v `seq` ()
+seqExpr (Con c as) = seqExprs as
+seqExpr (App f a) = seqExpr f `seq` seqExpr a
+seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
+seqExpr (Let b e) = seqBind b `seq` seqExpr e
+seqExpr (Case e b as) = seqExpr e `seq` seqBndr b `seq` seqAlts as
+seqExpr (Note n e) = seqNote n `seq` seqExpr e
+seqExpr (Type t) = seqType t
+
+seqExprs [] = ()
+seqExprs (e:es) = seqExpr e `seq` seqExprs es
+
+seqNote (Coerce t1 t2) = seqType t1 `seq` seqType t2
+seqNote other = ()
+
+seqBndr b = b `seq` ()
+
+seqBndrs [] = ()
+seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
+
+seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
+seqBind (Rec prs) = seqPairs prs
+
+seqPairs [] = ()
+seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
+
+seqAlts [] = ()
+seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
+
+seqRules :: CoreRules -> ()
+seqRules (Rules rules fvs) = seq_rules rules `seq` seqVarSet fvs
+
+seq_rules [] = ()
+seq_rules (Rule fs bs es e : rules) = seqBndrs bs `seq` seqExprs (e:es) `seq` seq_rules rules
+\end{code}
+
+\begin{code}
+coreBindsSize :: [CoreBind] -> Int
+coreBindsSize bs = foldr ((+) . bindSize) 0 bs
+
+exprSize :: CoreExpr -> Int
+ -- A measure of the size of the expressions
+ -- It also forces the expression pretty drastically as a side effect
+exprSize (Var v) = varSize v
+exprSize (Con c as) = c `seq` exprsSize as
+exprSize (App f a) = exprSize f + exprSize a
+exprSize (Lam b e) = varSize b + exprSize e
+exprSize (Let b e) = bindSize b + exprSize e
+exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
+exprSize (Note n e) = exprSize e
+exprSize (Type t) = seqType t `seq` 1
+
+exprsSize = foldr ((+) . exprSize) 0
+
+varSize :: IdOrTyVar -> Int
+varSize b | isTyVar b = 1
+ | otherwise = seqType (idType b) `seq`
+ megaSeqIdInfo (idInfo b) `seq`
+ 1
+
+varsSize = foldr ((+) . varSize) 0
+
+bindSize (NonRec b e) = varSize b + exprSize e
+bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
+
+pairSize (b,e) = varSize b + exprSize e
+
+altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
+\end{code}
+
+
%************************************************************************
%* *
\subsection{Annotated core; annotation at every node in the tree}
diff --git a/ghc/compiler/coreSyn/CoreUnfold.hi-boot b/ghc/compiler/coreSyn/CoreUnfold.hi-boot
index e670f2dcb7f0ab92d9804fbdef5bc3b61c8ff3dd..86ee1da8a30aa2bce2f89b67e5050228cdd81541 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.hi-boot
+++ b/ghc/compiler/coreSyn/CoreUnfold.hi-boot
@@ -1,10 +1,11 @@
_interface_ CoreUnfold 1
_exports_
-CoreUnfold Unfolding UnfoldingGuidance mkUnfolding noUnfolding hasUnfolding isEvaldUnfolding;
+CoreUnfold Unfolding UnfoldingGuidance mkUnfolding noUnfolding hasUnfolding isEvaldUnfolding seqUnfolding ;
_declarations_
1 data Unfolding;
1 data UnfoldingGuidance;
1 mkUnfolding _:_ CoreSyn.CoreExpr -> Unfolding ;;
1 noUnfolding _:_ Unfolding ;;
1 hasUnfolding _:_ Unfolding -> PrelBase.Bool ;;
+1 seqUnfolding _:_ Unfolding -> PrelBase.() ;;
1 isEvaldUnfolding _:_ Unfolding -> PrelBase.Bool ;;
diff --git a/ghc/compiler/coreSyn/CoreUnfold.hi-boot-5 b/ghc/compiler/coreSyn/CoreUnfold.hi-boot-5
index d86aa996ca5436d8f59232faef1427a63dffcaa2..32c1673d6590cc636bcfbf1fe0c239104377f72f 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.hi-boot-5
+++ b/ghc/compiler/coreSyn/CoreUnfold.hi-boot-5
@@ -1,8 +1,9 @@
__interface CoreUnfold 1 0 where
-__export CoreUnfold Unfolding UnfoldingGuidance mkUnfolding noUnfolding hasUnfolding isEvaldUnfolding;
+__export CoreUnfold Unfolding UnfoldingGuidance mkUnfolding noUnfolding hasUnfolding isEvaldUnfolding seqUnfolding ;
1 data Unfolding;
1 data UnfoldingGuidance;
1 mkUnfolding :: CoreSyn.CoreExpr -> Unfolding ;
1 noUnfolding :: Unfolding ;
1 hasUnfolding :: Unfolding -> PrelBase.Bool ;
+1 seqUnfolding :: Unfolding -> PrelBase.Z0T ;
1 isEvaldUnfolding :: Unfolding -> PrelBase.Bool ;
diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 0c8e6e1414d746090884989f461506489d37b69a..c59b9375e8bd562620d04534334ee8f08ab4d85f 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -16,7 +16,7 @@ find, unsurprisingly, a Core expression.
module CoreUnfold (
Unfolding, UnfoldingGuidance, -- types
- noUnfolding, mkUnfolding,
+ noUnfolding, mkUnfolding, seqUnfolding,
mkOtherCon, otherCons,
unfoldingTemplate, maybeUnfoldingTemplate,
isEvaldUnfolding, isCheapUnfolding,
@@ -26,7 +26,7 @@ module CoreUnfold (
certainlySmallEnoughToInline,
okToUnfoldInHiFile,
- calcUnfoldingGuidance,
+ calcUnfoldingGuidance,
callSiteInline, blackListed
) where
@@ -92,6 +92,11 @@ data Unfolding
Bool -- exprIsValue template (cached); it is ok to discard a `seq` on
-- this variable
UnfoldingGuidance -- Tells about the *size* of the template.
+
+seqUnfolding :: Unfolding -> ()
+seqUnfolding (CoreUnfolding e b1 b2 g)
+ = seqExpr e `seq` b1 `seq` b2 `seq` seqGuidance g
+seqUnfolding other = ()
\end{code}
\begin{code}
@@ -151,6 +156,9 @@ data UnfoldingGuidance
Int -- Scrutinee discount: the discount to substract if the thing is in
-- a context (case (thing args) of ...),
-- (where there are the right number of arguments.)
+
+seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
+seqGuidance other = ()
\end{code}
\begin{code}
diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs
index 64d4d502f683cce117413192cb8b42c94b0a4a81..7bc2c10476d371a83e70f9289f21817838056f34 100644
--- a/ghc/compiler/coreSyn/Subst.lhs
+++ b/ghc/compiler/coreSyn/Subst.lhs
@@ -32,7 +32,8 @@ module Subst (
#include "HsVersions.h"
import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreBndr,
- CoreRules(..), CoreRule(..), emptyCoreRules, isEmptyCoreRules
+ CoreRules(..), CoreRule(..),
+ emptyCoreRules, isEmptyCoreRules, seqRules
)
import CoreFVs ( exprFreeVars )
import Type ( Type(..), ThetaType, TyNote(..),
@@ -284,6 +285,7 @@ subst_expr subst expr
go (Var v) = case lookupSubst subst v of
Just (DoneEx e') -> e'
Just (ContEx env' e') -> subst_expr (setSubstEnv subst env') e'
+-- NO! NO! SLPJ 14 July 99
Nothing -> case lookupInScope subst v of
Just v' -> Var v'
Nothing -> Var v
@@ -293,6 +295,8 @@ subst_expr subst expr
-- of a variable may not be right; we should replace it with the
-- binder, from the in_scope set.
+-- Nothing -> Var v
+
go (Type ty) = Type (go_ty ty)
go (Con con args) = Con con (map go args)
go (App fun arg) = App (go fun) (go arg)
@@ -392,7 +396,7 @@ substAndCloneId subst@(Subst in_scope env) us old_id
where
id_ty = idType old_id
id1 | noTypeSubst env || isEmptyVarSet (tyVarsOfType id_ty) = old_id
- | otherwise = setIdType old_id (substTy subst id_ty)
+ | otherwise = setIdType old_id (substTy subst id_ty)
id2 = maybeModifyIdInfo zapFragileIdInfo id1
new_id = setVarUnique id2 (uniqFromSupply us1)
@@ -407,20 +411,35 @@ substAndCloneId subst@(Subst in_scope env) us old_id
%************************************************************************
\begin{code}
-substIdInfo :: Subst -> IdInfo -> IdInfo
-substIdInfo subst info
+substIdInfo :: Subst
+ -> IdInfo -- Get un-substituted ones from here
+ -> IdInfo -- Substitute it and add it to here
+ -> IdInfo -- To give this
+ -- Seq'ing on the returned IdInfo is enough to cause all the
+ -- substitutions to happen completely
+
+substIdInfo subst old_info new_info
= info2
where
- info1 | isEmptyCoreRules old_rules = info
- | otherwise = info `setSpecInfo` substRules subst old_rules
+ info1 | isEmptyCoreRules old_rules = new_info
+ | otherwise = new_info `setSpecInfo` new_rules
+ -- setSpecInfo does a seq
+ where
+ new_rules = substRules subst old_rules
info2 | not (workerExists old_wrkr) = info1
- | otherwise = info1 `setWorkerInfo` substWorker subst old_wrkr
+ | otherwise = info1 `setWorkerInfo` new_wrkr
+ -- setWorkerInfo does a seq
+ where
+ new_wrkr = substWorker subst old_wrkr
- old_rules = specInfo info
- old_wrkr = workerInfo info
+ old_rules = specInfo old_info
+ old_wrkr = workerInfo old_info
substWorker :: Subst -> WorkerInfo -> WorkerInfo
+ -- Seq'ing on the returned WorkerInfo is enough to cause all the
+ -- substitutions to happen completely
+
substWorker subst Nothing
= Nothing
substWorker subst (Just w)
@@ -433,10 +452,18 @@ substWorker subst (Just w)
Nothing -- Ditto
substRules :: Subst -> CoreRules -> CoreRules
+ -- Seq'ing on the returned CoreRules is enough to cause all the
+ -- substitutions to happen completely
+
+substRules subst rules
+ | isEmptySubst subst = rules
+
substRules subst (Rules rules rhs_fvs)
- = Rules (map do_subst rules)
- (subst_fvs (substEnv subst) rhs_fvs)
+ = seqRules new_rules `seq` new_rules
where
+ new_rules = Rules (map do_subst rules)
+ (subst_fvs (substEnv subst) rhs_fvs)
+
do_subst (Rule name tpl_vars lhs_args rhs)
= Rule name tpl_vars'
(map (substExpr subst') lhs_args)
diff --git a/ghc/compiler/cprAnalysis/CprAnalyse.lhs b/ghc/compiler/cprAnalysis/CprAnalyse.lhs
index 3b2fa312cb9f9206368823c270e764e43bb16799..e99864ffdb61ba84a2b65138fbd99c7536779a07 100644
--- a/ghc/compiler/cprAnalysis/CprAnalyse.lhs
+++ b/ghc/compiler/cprAnalysis/CprAnalyse.lhs
@@ -15,10 +15,9 @@ import Var ( Var, Id, TyVar, idType, varName, varType )
import Id ( setIdCprInfo, getIdCprInfo, getIdUnfolding )
import IdInfo ( CprInfo(..) )
import VarEnv
-import Type ( Type(..), splitFunTys, splitForAllTys, splitTyConApp_maybe,
- splitAlgTyConApp_maybe )
+import Type ( Type(..), splitFunTys, splitForAllTys, splitNewType_maybe )
import TyCon ( isProductTyCon, isNewTyCon, isUnLiftedTyCon )
-import DataCon ( dataConTyCon, dataConArgTys )
+import DataCon ( dataConTyCon, splitProductType_maybe )
import Const ( Con(DataCon), isWHNFCon )
import Util ( zipEqual, zipWithEqual )
import Outputable
@@ -317,23 +316,16 @@ pinCPR v e av = case av of
filterAbsTuple :: (AbsVal, Type) -> AbsVal
filterAbsTuple (av@(Tuple args), ty)
- = case split_ty of
- Nothing -> Top
- Just (data_con, tycon, tycon_arg_tys, inst_con_arg_tys) ->
- if isNewTyCon tycon then
- ASSERT ( null $ tail inst_con_arg_tys )
- filterAbsTuple (av, head inst_con_arg_tys)
- else
- Tuple $ map filterAbsTuple $ zipEqual "cprFilter" args inst_con_arg_tys
- where
- split_ty = case splitAlgTyConApp_maybe ty of
- Just (arg_tycon, tycon_arg_tys, [data_con]) ->
- -- The main event: a single-constructor data type
- Just (data_con, arg_tycon, tycon_arg_tys, dataConArgTys data_con tycon_arg_tys)
- Just (_, _, data_cons) ->
- pprPanic "cprFilter:" (text "not one constructor" $$ ppr ty)
- -- hmmm, Isn't this a panic too?
- Nothing -> Nothing
+ = case splitProductType_maybe ty of
+ Nothing -> WARN( True, text "filterAbsTuple" <+> ppr ty) -- Or should it be a panic?
+ Top
+ Just (tycon, _, data_con, inst_con_arg_tys)
+ | isNewTyCon tycon
+ -> ASSERT ( null $ tail inst_con_arg_tys )
+ filterAbsTuple (av, head inst_con_arg_tys)
+ | otherwise
+ -> Tuple $ map filterAbsTuple $ zipEqual "cprFilter" args inst_con_arg_tys
+
filterAbsTuple (av, _) = av
absToCprInfo :: AbsVal -> CprInfo
@@ -376,23 +368,15 @@ splitTypeToFunArgAndRes ty = (tyvars, argtys, resty)
-- Taken from splitFunTys in Type.lhs. Modified to keep searching through newtypes
-- Should move to Type.lhs if it is doing something sensible.
splitFunTysIgnoringNewTypes :: Type -> ([Type], Type)
-splitFunTysIgnoringNewTypes ty = split [] ty ty
+splitFunTysIgnoringNewTypes ty = split ty
where
- split args orig_ty (FunTy arg res) = split (arg:args) res res
- split args orig_ty (NoteTy _ ty) = split args orig_ty ty
- split args orig_ty ty
- = case splitAlgTyConApp_maybe ty of
- Just (arg_tycon, tycon_arg_tys, [data_con]) ->
- let [inst_con_arg_ty] = dataConArgTys data_con tycon_arg_tys in
- if (isNewTyCon arg_tycon) then
- {- pprTrace "splitFunTysIgnoringNewTypes:"
- (ppr arg_tycon <+> text "from type" <+> ppr inst_con_arg_ty)
- -}
- (split args orig_ty inst_con_arg_ty)
- else
- (reverse args, orig_ty)
- Nothing -> (reverse args, orig_ty)
-
+ split ty = case splitNewType_maybe res of
+ Nothing -> (args, res)
+ Just rep_ty -> (args ++ args', res')
+ where
+ (args', res') = split rep_ty
+ where
+ (args, res) = splitFunTys ty
-- Is this the constructor for a product type (i.e. algebraic, single constructor)
isConProdType :: Con -> Bool
diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index 84631e39f419a9424d4aaa9b3a1152e13c95945a..ece7e71ab91b3425f22887e438a38d4ba4292b84 100644
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -27,7 +27,7 @@ import Const ( Con(..) )
import Maybes ( maybeToBool )
import PrelInfo ( packStringForCId )
import PrimOp ( PrimOp(..) )
-import DataCon ( DataCon, dataConId, dataConArgTys )
+import DataCon ( DataCon, dataConId, splitProductType_maybe )
import CallConv
import Type ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys,
splitTyConApp_maybe, Type
@@ -84,7 +84,7 @@ dsCCall :: FAST_STRING -- C routine to invoke
-> Type -- Type of the result (a boxed-prim IO type)
-> DsM CoreExpr
-dsCCall label args may_gc is_asm result_ty
+dsCCall lbl args may_gc is_asm result_ty
= newSysLocalDs realWorldStatePrimTy `thenDs` \ old_s ->
mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
@@ -98,7 +98,7 @@ dsCCall label args may_gc is_asm result_ty
-- it at the full type, including the state argument
inst_ty = mkFunTys (map coreExprType val_args) final_result_ty
- the_ccall_op = CCallOp (Left label) is_asm may_gc cCallConv
+ the_ccall_op = CCallOp (Left lbl) is_asm may_gc cCallConv
the_prim_app = mkPrimApp the_ccall_op final_args
the_body = foldr ($) (res_wrapper the_prim_app) arg_wrappers
@@ -134,12 +134,8 @@ unboxArg arg
\body -> Case (App (Var packStringForCId) arg)
prim_arg [(DEFAULT,[],body)])
- | null data_cons
- -- oops: we can't see the data constructors!!!
- = can'tSeeDataConsPanic "argument" arg_ty
-
-- Byte-arrays, both mutable and otherwise; hack warning
- | is_data_type &&
+ | is_product_type &&
length data_con_arg_tys == 2 &&
maybeToBool maybe_arg2_tycon &&
(arg2_tycon == byteArrayPrimTyCon ||
@@ -148,7 +144,7 @@ unboxArg arg
= newSysLocalDs arg_ty `thenDs` \ case_bndr ->
newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[ixs_var, arr_cts_var] ->
returnDs (Var arr_cts_var,
- \ body -> Case arg case_bndr [(DataCon the_data_con,vars,body)]
+ \ body -> Case arg case_bndr [(DataCon data_con,vars,body)]
)
-- Data types with a single constructor, which has a single, primitive-typed arg
@@ -168,13 +164,10 @@ unboxArg arg
maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty
(Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty
- maybe_data_type = splitAlgTyConApp_maybe arg_ty
- is_data_type = maybeToBool maybe_data_type
- (Just (tycon, tycon_arg_tys, data_cons)) = maybe_data_type
- (the_data_con : other_data_cons) = data_cons
-
- data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
- (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
+ maybe_product_type = splitProductType_maybe arg_ty
+ is_product_type = maybeToBool maybe_product_type
+ Just (tycon, _, data_con, data_con_arg_tys) = maybe_product_type
+ (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2
Just (arg2_tycon,_) = maybe_arg2_tycon
@@ -193,13 +186,8 @@ boxResult :: Type -- Type of desired result
CoreExpr -> CoreExpr) -- Wrapper for the ccall
-- to box the result
boxResult result_ty
- | null data_cons
- -- oops! can't see the data constructors
- = can'tSeeDataConsPanic "result" result_ty
-
-- Data types with a single nullary constructor
- | (maybeToBool maybe_data_type) && -- Data type
- (null other_data_cons) && -- Just one constr
+ | (maybeToBool maybe_product_type) && -- Data type
(null data_con_arg_tys)
=
newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
@@ -222,8 +210,7 @@ boxResult result_ty
)
-- Data types with a single constructor, which has a single, primitive-typed arg
- | (maybeToBool maybe_data_type) && -- Data type
- (null other_data_cons) && -- Just one constr
+ | (maybeToBool maybe_product_type) && -- Data type
not (null data_con_arg_tys) && null other_args_tys && -- Just one arg
isUnLiftedType the_prim_result_ty -- of primitive type
=
@@ -232,7 +219,7 @@ boxResult result_ty
newSysLocalDs ccall_res_type `thenDs` \ case_bndr ->
let
- the_result = mkConApp the_data_con (map Type tycon_arg_tys ++ [Var prim_result_id])
+ the_result = mkConApp data_con (map Type tycon_arg_tys ++ [Var prim_result_id])
the_pair = mkConApp unboxedPairDataCon
[Type realWorldStatePrimTy, Type result_ty,
Var prim_state_id, the_result]
@@ -244,52 +231,39 @@ boxResult result_ty
| otherwise
= pprPanic "boxResult: " (ppr result_ty)
where
- maybe_data_type = splitAlgTyConApp_maybe result_ty
- Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
- (the_data_con : other_data_cons) = data_cons
- ccall_res_type = mkUnboxedTupleTy 2
- [realWorldStatePrimTy, the_prim_result_ty]
+ maybe_product_type = splitProductType_maybe result_ty
+ Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type
+ (the_prim_result_ty : other_args_tys) = data_con_arg_tys
- data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
- (the_prim_result_ty : other_args_tys) = data_con_arg_tys
+ ccall_res_type = mkUnboxedTupleTy 2 [realWorldStatePrimTy, the_prim_result_ty]
-- wrap up an unboxed value.
wrapUnboxedValue :: Type -> DsM (Type, Id, CoreExpr)
wrapUnboxedValue ty
- | null data_cons
- -- oops! can't see the data constructors
- = can'tSeeDataConsPanic "result" ty
- -- Data types with a single constructor, which has a single, primitive-typed arg
- | (maybeToBool maybe_data_type) && -- Data type
- (null other_data_cons) && -- Just one constr
+ | (maybeToBool maybe_product_type) && -- Data type
not (null data_con_arg_tys) && null other_args_tys && -- Just one arg
isUnLiftedType the_prim_result_ty -- of primitive type
=
newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id ->
let
- the_result = mkConApp the_data_con (map Type tycon_arg_tys ++ [Var prim_result_id])
+ the_result = mkConApp data_con (map Type tycon_arg_tys ++ [Var prim_result_id])
in
returnDs (ccall_res_type, prim_result_id, the_result)
-- Data types with a single nullary constructor
- | (maybeToBool maybe_data_type) && -- Data type
- (null other_data_cons) && -- Just one constr
+ | (maybeToBool maybe_product_type) && -- Data type
(null data_con_arg_tys)
=
let unit = dataConId unitDataCon
scrut_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy]
in
returnDs (scrut_ty, unit, mkConApp unitDataCon [])
+
| otherwise
= pprPanic "boxResult: " (ppr ty)
where
- maybe_data_type = splitAlgTyConApp_maybe ty
- Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
- (the_data_con : other_data_cons) = data_cons
- ccall_res_type = mkUnboxedTupleTy 2
- [realWorldStatePrimTy, the_prim_result_ty]
-
- data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
- (the_prim_result_ty : other_args_tys) = data_con_arg_tys
-
+ maybe_product_type = splitProductType_maybe ty
+ Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type
+ (the_prim_result_ty : other_args_tys) = data_con_arg_tys
+ ccall_res_type = mkUnboxedTupleTy 2 [realWorldStatePrimTy, the_prim_result_ty]
\end{code}
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index a8421fd0b0f31ca263aa55d81c93178df6f716bc..c1a2d6ec300e455d360a868baaa0e054d49fe005 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -309,9 +309,9 @@ dsExpr (SectionR op expr)
returnDs (bindNonRec y_id y_core $
Lam x_id (mkApps core_op [Var x_id, Var y_id]))
-dsExpr (CCall label args may_gc is_asm result_ty)
+dsExpr (CCall lbl args may_gc is_asm result_ty)
= mapDs dsExpr args `thenDs` \ core_args ->
- dsCCall label core_args may_gc is_asm result_ty
+ dsCCall lbl core_args may_gc is_asm result_ty
-- dsCCall does all the unboxification, etc.
dsExpr (HsSCC cc expr)
@@ -543,6 +543,7 @@ dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds)
mk_alt con
= newSysLocalsDs (dataConArgTys con in_inst_tys) `thenDs` \ arg_ids ->
+ -- This call to dataConArgTys won't work for existentials
let
val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
(dataConFieldLabels con) arg_ids
diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index b6abdbf1c30ec212b5e961be81ec35c7f5dc8f85..1abd67fed5f156af82d848c9d0a3cc967616dc9e 100644
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -137,7 +137,7 @@ dsFImport nm ty may_not_gc ext_name cconv =
(case ext_name of
Dynamic -> getUniqueDs `thenDs` \ u ->
returnDs (Right u)
- ExtName fs _ -> returnDs (Left fs)) `thenDs` \ label ->
+ ExtName fs _ -> returnDs (Left fs)) `thenDs` \ lbl ->
let
val_args = Var the_state_arg : unboxed_args
final_args = Type inst_ty : val_args
@@ -146,7 +146,7 @@ dsFImport nm ty may_not_gc ext_name cconv =
-- it at the full type, including the state argument
inst_ty = mkFunTys (map coreExprType val_args) final_result_ty
- the_ccall_op = CCallOp label False (not may_not_gc) cconv
+ the_ccall_op = CCallOp lbl False (not may_not_gc) cconv
the_prim_app = mkPrimApp the_ccall_op (final_args :: [CoreArg])
diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 98a7177e84e66cf0fd5d2c246283ba30a758c52a..455b41b3fd12930da2eaf202b4b53a290694ab02 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -42,7 +42,7 @@ import Id ( idType, Id, mkWildId )
import Const ( Literal(..), Con(..) )
import TyCon ( isNewTyCon, tyConDataCons )
import DataCon ( DataCon, StrictnessMark, maybeMarkedUnboxed, dataConStrictMarks,
- dataConArgTys, dataConId
+ dataConId, splitProductType_maybe
)
import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp, unUsgTy,
Type
@@ -274,18 +274,19 @@ rebuildConArgs con (arg:args) stricts body | isTyVar arg
rebuildConArgs con (arg:args) (str:stricts) body
= rebuildConArgs con args stricts body `thenDs` \ (body', real_args) ->
case maybeMarkedUnboxed str of
- Just (pack_con, tys) ->
- let id_tys = dataConArgTys pack_con ty_args in
- newSysLocalsDs id_tys `thenDs` \ unpacked_args ->
- returnDs (
- mkDsLet (NonRec arg (Con (DataCon pack_con)
- (map Type ty_args ++
- map Var unpacked_args))) body',
- unpacked_args ++ real_args
- )
+ 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 (Con (DataCon pack_con)
+ (map Type tycon_args ++
+ map Var unpacked_args))) body',
+ unpacked_args ++ real_args
+ )
+
_ -> returnDs (body', arg:real_args)
-
- where ty_args = case splitAlgTyConApp (idType arg) of { (_,args,_) -> args }
\end{code}
%************************************************************************
diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index 6c242a9c9bf52e8e69c8af34b4f797189d2416f3..890cba9636ab02b11532173fa3e5b8f213bf327a 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -28,7 +28,7 @@ import MatchCon ( matchConFamily )
import MatchLit ( matchLiterals )
import PrelInfo ( pAT_ERROR_ID )
import Type ( isUnLiftedType, splitAlgTyConApp,
- Type
+ mkTyVarTys, Type
)
import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy,
addrPrimTy, wordPrimTy
@@ -457,21 +457,21 @@ tidy1 v (LazyPat pat) match_result
-- re-express <con-something> as (ConPat ...) [directly]
-tidy1 v (RecPat data_con pat_ty tvs dicts rpats) match_result
+tidy1 v (RecPat data_con pat_ty ex_tvs dicts rpats) match_result
| null rpats
= -- Special case for C {}, which can be used for
-- a constructor that isn't declared to have
-- fields at all
- returnDs (ConPat data_con pat_ty tvs dicts (map WildPat con_arg_tys'), match_result)
+ returnDs (ConPat data_con pat_ty ex_tvs dicts (map WildPat con_arg_tys'), match_result)
| otherwise
- = returnDs (ConPat data_con pat_ty tvs dicts pats, match_result)
+ = returnDs (ConPat data_con pat_ty ex_tvs dicts pats, match_result)
where
pats = map mk_pat tagged_arg_tys
-- Boring stuff to find the arg-tys of the constructor
(_, inst_tys, _) = splitAlgTyConApp pat_ty
- con_arg_tys' = dataConArgTys data_con inst_tys
+ con_arg_tys' = dataConArgTys data_con (inst_tys ++ mkTyVarTys ex_tvs)
tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels data_con)
-- mk_pat picks a WildPat of the appropriate type for absent fields,
diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index caa8a6ba848af25c8b5a2ad1efba43324fc60f56..128c812dcb33cb657ce0c67895830a0c599dd7b8 100644
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -154,6 +154,7 @@ data HsExpr id pat
\end{code}
These constructors only appear temporarily in the parser.
+The renamer translates them into the Right Thing.
\begin{code}
| EWildPat -- wildcard
@@ -329,14 +330,18 @@ ppr_expr (ArithSeqIn info)
ppr_expr (ArithSeqOut expr info)
= brackets (ppr info)
+ppr_expr EWildPat = char '_'
+ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e
+ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e
+
ppr_expr (CCall fun args _ is_asm result_ty)
= hang (if is_asm
then ptext SLIT("_casm_ ``") <> ptext fun <> ptext SLIT("''")
else ptext SLIT("_ccall_") <+> ptext fun)
4 (sep (map pprParendExpr args))
-ppr_expr (HsSCC label expr)
- = sep [ ptext SLIT("_scc_") <+> doubleQuotes (ptext label), pprParendExpr expr ]
+ppr_expr (HsSCC lbl expr)
+ = sep [ ptext SLIT("_scc_") <+> doubleQuotes (ptext lbl), pprParendExpr expr ]
ppr_expr (TyLam tyvars expr)
= hang (hsep [ptext SLIT("/\\"), interppSP tyvars, ptext SLIT("->")])
diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs
index 176bf9ce986cbd284e8bb30c150a823b634ffaa7..1712dca92039ef458fa78e2baa5a8ae1cbed22f7 100644
--- a/ghc/compiler/main/Main.lhs
+++ b/ghc/compiler/main/Main.lhs
@@ -26,6 +26,7 @@ import TcModule ( TcResults(..), typecheckModule )
import Desugar ( deSugar )
import SimplCore ( core2core )
import CoreLint ( endPass )
+import CoreSyn ( coreBindsSize )
import CoreTidy ( tidyCorePgm )
import CoreToStg ( topCoreBindsToStg )
import StgSyn ( collectFinalStgBinders, pprStgBindings )
@@ -180,6 +181,11 @@ doIt (core_cmds, stg_cmds)
let
final_ids = collectFinalStgBinders (map fst stg_binds2)
in
+ coreBindsSize tidy_binds `seq`
+-- TEMP: the above call zaps some space usage allocated by the
+-- simplifier, which for reasons I don't understand, persists
+-- thoroughout code generation
+
ifaceDecls if_handle local_tycons local_classes
inst_info final_ids tidy_binds imp_rule_ids >>
endIface if_handle >>
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 2fec609e8568396a67685dfb2b8e59314860bc7d..53a70be5ff209231e3823014bbf35c18b8b2e216 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -292,7 +292,8 @@ ifaceId get_idinfo needed_ids is_rec id rhs
ifaceId get_idinfo needed_ids is_rec id rhs
= Just (hsep [sig_pretty, prag_pretty, char ';'], new_needed_ids)
where
- idinfo = get_idinfo id
+ core_idinfo = idInfo id
+ stg_idinfo = get_idinfo id
ty_pretty = pprType (idType id)
sig_pretty = hsep [ppr (getOccName id), dcolon, ty_pretty]
@@ -309,28 +310,28 @@ ifaceId get_idinfo needed_ids is_rec id rhs
ptext SLIT("##-}")]
------------ Arity --------------
- arity_pretty = ppArityInfo (arityInfo idinfo)
+ arity_pretty = ppArityInfo (arityInfo stg_idinfo)
------------ Caf Info --------------
- caf_pretty = ppCafInfo (cafInfo idinfo)
+ caf_pretty = ppCafInfo (cafInfo stg_idinfo)
------------ CPR Info --------------
- cpr_pretty = ppCprInfo (cprInfo idinfo)
+ cpr_pretty = ppCprInfo (cprInfo core_idinfo)
------------ Strictness --------------
- strict_info = strictnessInfo idinfo
+ strict_info = strictnessInfo core_idinfo
bottoming_fn = isBottomingStrictness strict_info
strict_pretty = ppStrictnessInfo strict_info
------------ Worker --------------
- work_info = workerInfo idinfo
+ work_info = workerInfo core_idinfo
has_worker = workerExists work_info
wrkr_pretty = ppWorkerInfo work_info
Just work_id = work_info
------------ Unfolding --------------
- inline_pragma = inlinePragInfo idinfo
+ inline_pragma = inlinePragInfo core_idinfo
dont_inline = case inline_pragma of
IMustNotBeINLINEd -> True
IAmALoopBreaker -> True
@@ -348,7 +349,7 @@ ifaceId get_idinfo needed_ids is_rec id rhs
rhs_is_small = couldBeSmallEnoughToInline (calcUnfoldingGuidance opt_UF_HiFileThreshold rhs)
------------ Specialisations --------------
- spec_info = specInfo idinfo
+ spec_info = specInfo core_idinfo
------------ Extra free Ids --------------
new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs
index e4c1968d44293688baf6f0239ab9df4a3de9a0af..4c7553f27a096c648403f51ec7c24fda32145dd4 100644
--- a/ghc/compiler/nativeGen/AbsCStixGen.lhs
+++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs
@@ -74,17 +74,17 @@ Here we handle top-level things, like @CCodeBlock@s and
-> UniqSM [StixTree]
-}
- gentopcode (CCodeBlock label absC)
+ gentopcode (CCodeBlock lbl absC)
= gencode absC `thenUs` \ code ->
- returnUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label])
+ returnUs (StSegment TextSegment : StFunBegin lbl : code [StFunEnd lbl])
- gentopcode stmt@(CStaticClosure label _ _ _)
+ gentopcode stmt@(CStaticClosure lbl _ _ _)
= genCodeStaticClosure stmt `thenUs` \ code ->
- returnUs (StSegment DataSegment : StLabel label : code [])
+ returnUs (StSegment DataSegment : StLabel lbl : code [])
- gentopcode stmt@(CRetVector label _ _ _)
+ gentopcode stmt@(CRetVector lbl _ _ _)
= genCodeVecTbl stmt `thenUs` \ code ->
- returnUs (StSegment TextSegment : code [StLabel label])
+ returnUs (StSegment TextSegment : code [StLabel lbl])
gentopcode stmt@(CRetDirect uniq absC srt liveness)
= gencode absC `thenUs` \ code ->
@@ -150,7 +150,7 @@ Here we handle top-level things, like @CCodeBlock@s and
:: AbstractC
-> UniqSM StixTreeList
-}
- genCodeVecTbl (CRetVector label amodes srt liveness)
+ genCodeVecTbl (CRetVector lbl amodes srt liveness)
= genBitmapInfoTable liveness srt closure_type True `thenUs` \itbl ->
returnUs (\xs -> vectbl : itbl xs)
where
diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs
index 3871d484177bfd05aebf85b04bc5ce65b6f96db3..abfb793e2c9117ed082c35fc020db4256a01b8fe 100644
--- a/ghc/compiler/nativeGen/AsmCodeGen.lhs
+++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs
@@ -339,8 +339,8 @@ fltFix1 locs (StAssign rep dst src) = panic "fltFix1: StAssign"
fltFix1 locs (StJump tree) = StJump (fltFix1 locs tree)
-fltFix1 locs (StCondJump label tree) =
- StCondJump label (fltFix1 locs tree)
+fltFix1 locs (StCondJump lbl tree) =
+ StCondJump lbl (fltFix1 locs tree)
fltFix1 locs (StPrim op trees) =
StPrim op (map (fltFix1 locs) trees)
diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs
index 50d57094b573c95d03fe4ba6ee2445f134935f26..811a39a0eece3dbb021043dd2a00a8721dbfa8d9 100644
--- a/ghc/compiler/nativeGen/RegAllocInfo.lhs
+++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs
@@ -374,7 +374,7 @@ regUsage instr = case instr of
TEST sz src dst -> usage (opToReg src ++ opToReg dst) []
CMP sz src dst -> usage (opToReg src ++ opToReg dst) []
SETCC cond op -> usage [] (opToReg op)
- JXX cond label -> usage [] []
+ JXX cond lbl -> usage [] []
JMP op -> usage (opToReg op) freeRegs
CALL imm -> usage [] callClobberedRegs
CLTD -> usage [eax] [edx]
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 5e55fd09a1fc5a4a89065f2df64e8cdec01c7369..aecf9a95d1dba420bddea1fa6a24bd35388ac6f7 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -350,9 +350,9 @@ rnExpr (CCall fun args may_gc is_casm fake_result_ty)
returnRn (CCall fun args' may_gc is_casm fake_result_ty,
fvs_args `addOneFV` cc `addOneFV` cr `addOneFV` io)
-rnExpr (HsSCC label expr)
+rnExpr (HsSCC lbl expr)
= rnExpr expr `thenRn` \ (expr', fvs_expr) ->
- returnRn (HsSCC label expr', fvs_expr)
+ returnRn (HsSCC lbl expr', fvs_expr)
rnExpr (HsCase expr ms src_loc)
= pushSrcLocRn src_loc $
@@ -430,6 +430,21 @@ rnExpr (ArithSeqIn seq)
plusFVs [fvExpr1, fvExpr2, fvExpr3])
\end{code}
+These three are pattern syntax appearing in expressions.
+Since all the symbols are reservedops we can simply reject them.
+We return a (bogus) EWildPat in each case.
+
+\begin{code}
+rnExpr e@EWildPat = addErrRn (patSynErr e) `thenRn_`
+ returnRn (EWildPat, emptyFVs)
+
+rnExpr e@(EAsPat _ _) = addErrRn (patSynErr e) `thenRn_`
+ returnRn (EWildPat, emptyFVs)
+
+rnExpr e@(ELazyPat _) = addErrRn (patSynErr e) `thenRn_`
+ returnRn (EWildPat, emptyFVs)
+\end{code}
+
%************************************************************************
%* *
\subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
@@ -833,4 +848,8 @@ patSigErr ty
$$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
pp_op (op, fix) = hcat [ppr op, space, parens (ppr fix)]
+
+patSynErr e
+ = sep [ptext SLIT("Pattern syntax in expression context:"),
+ nest 4 (ppr e)]
\end{code}
diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index e74525d0349bb5eb3ad3f931048d2514c783be09..13970ffa2eb99c5c98958b6dcb07661e0f74ba79 100644
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -663,7 +663,7 @@ cloneVar NotTopLevel (lvl_env, subst_env) v lvl
let
subst = mkSubst emptyVarSet subst_env
v' = setVarUnique v uniq
- v'' = modifyIdInfo (substIdInfo subst) v'
+ v'' = modifyIdInfo (\info -> substIdInfo subst info info) v'
subst_env' = extendSubstEnv subst_env v (DoneEx (Var v''))
lvl_env' = extendVarEnv lvl_env v lvl
in
@@ -677,7 +677,7 @@ cloneVars NotTopLevel (lvl_env, subst_env) vs lvl
let
subst = mkSubst emptyVarSet subst_env'
vs' = zipWith setVarUnique vs uniqs
- vs'' = map (modifyIdInfo (substIdInfo subst)) vs'
+ vs'' = map (modifyIdInfo (\info -> substIdInfo subst info info)) vs'
subst_env' = extendSubstEnvList subst_env vs [DoneEx (Var v'') | v'' <- vs'']
lvl_env' = extendVarEnvList lvl_env (vs `zip` repeat lvl)
in
diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs
index 32d8d6b002f20a899503467aac180a6bbcf6ef90..a946da4d4997806afcb228e075b0d18e9f14f4d0 100644
--- a/ghc/compiler/simplCore/SimplMonad.lhs
+++ b/ghc/compiler/simplCore/SimplMonad.lhs
@@ -568,7 +568,6 @@ data Tick
| FillInCaseDefault Id -- Case binder
| BottomFound
- | LeafVisit
| SimplifierDone -- Ticked at each iteration of the simplifier
isRuleFired (RuleFired _) = True
@@ -599,7 +598,6 @@ tickToTag (CaseElim _) = 11
tickToTag (CaseIdentity _) = 12
tickToTag (FillInCaseDefault _) = 13
tickToTag BottomFound = 14
-tickToTag LeafVisit = 15
tickToTag SimplifierDone = 16
tickString :: Tick -> String
@@ -619,7 +617,6 @@ tickString (CaseIdentity _) = "CaseIdentity"
tickString (FillInCaseDefault _) = "FillInCaseDefault"
tickString BottomFound = "BottomFound"
tickString SimplifierDone = "SimplifierDone"
-tickString LeafVisit = "LeafVisit"
pprTickCts :: Tick -> SDoc
pprTickCts (PreInlineUnconditionally v) = ppr v
diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 7ce7e2770f180162f55c69faf249542536e44241..a5877bd523ff2298dd2458a6031f0e9db4f4632e 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -22,14 +22,14 @@ import CoreUtils ( exprIsTrivial, cheapEqExpr, coreExprType, exprIsCheap, exprGe
import Subst ( substBndrs, substBndr, substIds )
import Id ( Id, idType, getIdArity, isId, idName,
getInlinePragma, setInlinePragma,
- getIdDemandInfo, mkId
+ getIdDemandInfo, mkId, idInfo
)
import IdInfo ( arityLowerBound, InlinePragInfo(..), setInlinePragInfo, vanillaIdInfo )
import Maybes ( maybeToBool, catMaybes )
import Const ( Con(..) )
import Name ( isLocalName, setNameUnique )
import SimplMonad
-import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys,
+import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType,
splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys
)
import TysPrim ( statePrimTyCon )
@@ -54,8 +54,8 @@ simplBinders bndrs thing_inside
let
(subst', bndrs') = substBndrs subst bndrs
in
- setSubst subst' $
- thing_inside bndrs'
+ seqBndrs bndrs' `seq`
+ setSubst subst' (thing_inside bndrs')
simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
simplBinder bndr thing_inside
@@ -63,8 +63,8 @@ simplBinder bndr thing_inside
let
(subst', bndr') = substBndr subst bndr
in
- setSubst subst' $
- thing_inside bndr'
+ seqBndr bndr' `seq`
+ setSubst subst' (thing_inside bndr')
-- Same semantics as simplBinders, but a little less
@@ -76,8 +76,16 @@ simplIds ids thing_inside
let
(subst', bndrs') = substIds subst ids
in
- setSubst subst' $
- thing_inside bndrs'
+ seqBndrs bndrs' `seq`
+ setSubst subst' (thing_inside bndrs')
+
+seqBndrs [] = ()
+seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
+
+seqBndr b | isTyVar b = b `seq` ()
+ | otherwise = seqType (idType b) `seq`
+ idInfo b `seq`
+ ()
\end{code}
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index bb7fc9e919b201f3d076a0216f5ca1eba35ab7f6..64ff7b043a0b1da2e6f424898ccd8e4ce4a05453 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -27,10 +27,10 @@ import Id ( Id, idType, idInfo, idUnique,
getIdArity, setIdArity, setIdInfo,
getIdStrictness,
setInlinePragma, getInlinePragma, idMustBeINLINEd,
- setOneShotLambda
+ setOneShotLambda, maybeModifyIdInfo
)
import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..),
- ArityInfo(..), atLeastArity, arityLowerBound, unknownArity,
+ ArityInfo(..), atLeastArity, arityLowerBound, unknownArity, zapFragileIdInfo,
specInfo, inlinePragInfo, zapLamIdInfo, setArityInfo, setInlinePragInfo, setUnfoldingInfo
)
import Demand ( Demand, isStrict, wwLazy )
@@ -51,7 +51,7 @@ import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsCheap, exprIsTrivial,
)
import Rules ( lookupRule )
import CostCentre ( isSubsumedCCS, currentCCS, isEmptyCC )
-import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType,
+import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, seqType,
mkFunTy, splitFunTys, splitTyConApp_maybe, splitFunTy_maybe,
funResultTy, isDictTy, isDataType, applyTy, applyTys, mkFunTys
)
@@ -95,8 +95,11 @@ simplTopBinds binds
top_binders = bindersOfBinds binds
simpl_binds [] = returnSmpl ([], panic "simplTopBinds corner")
- simpl_binds (NonRec bndr rhs : binds) = simplLazyBind TopLevel bndr bndr rhs (simpl_binds binds)
- simpl_binds (Rec pairs : binds) = simplRecBind TopLevel pairs (map fst pairs) (simpl_binds binds)
+ simpl_binds (NonRec bndr rhs : binds) = simplLazyBind TopLevel bndr (zap bndr) rhs (simpl_binds binds)
+ simpl_binds (Rec pairs : binds) = simplRecBind TopLevel pairs (map (zap . fst) pairs) (simpl_binds binds)
+
+ zap id = maybeModifyIdInfo zapFragileIdInfo id
+-- TEMP
simplRecBind :: TopLevelFlag -> [(InId, InExpr)] -> [OutId]
@@ -174,7 +177,8 @@ simplExpr expr = getSubst `thenSmpl` \ subst ->
simplExprC expr (Stop (substTy subst (coreExprType expr)))
-- The type in the Stop continuation is usually not used
-- It's only needed when discarding continuations after finding
- -- a function that returns bottom
+ -- a function that returns bottom.
+ -- Hence the lazy substitution
simplExprC :: CoreExpr -> SimplCont -> SimplM CoreExpr
-- Simplify an expression, given a continuation
@@ -213,13 +217,11 @@ simplExprF expr@(Con (PrimOp op) args) cont
Nothing -> rebuild (Con (PrimOp op) args2) cont2
simplExprF (Con con@(DataCon _) args) cont
- = freeTick LeafVisit `thenSmpl_`
- simplConArgs args ( \ args' ->
+ = simplConArgs args ( \ args' ->
rebuild (Con con args') cont)
simplExprF expr@(Con con@(Literal _) args) cont
= ASSERT( null args )
- freeTick LeafVisit `thenSmpl_`
rebuild expr cont
simplExprF (App fun arg) cont
@@ -247,8 +249,8 @@ simplExprF (Type ty) cont
simplExprF (Note (Coerce to from) e) cont
| to == from = simplExprF e cont
- | otherwise = getSubst `thenSmpl` \ subst ->
- simplExprF e (CoerceIt (substTy subst to) cont)
+ | otherwise = simplType to `thenSmpl` \ to' ->
+ simplExprF e (CoerceIt to' cont)
-- hack: we only distinguish subsumed cost centre stacks for the purposes of
-- inlining. All other CCCSs are mapped to currentCCS.
@@ -314,6 +316,7 @@ simplLam fun cont
let
ty' = substTy (mkSubst in_scope arg_se) ty_arg
in
+ seqType ty' `seq`
extendSubst bndr (DoneTy ty')
(go body body_cont)
@@ -411,7 +414,11 @@ simplConArgs (arg:args) thing_inside
simplType :: InType -> SimplM OutType
simplType ty
= getSubst `thenSmpl` \ subst ->
- returnSmpl (substTy subst ty)
+ let
+ new_ty = substTy subst ty
+ in
+ seqType new_ty `seq`
+ returnSmpl new_ty
\end{code}
@@ -533,24 +540,25 @@ completeBinding old_bndr new_bndr new_rhs thing_inside
let
-- We make new IdInfo for the new binder by starting from the old binder,
-- doing appropriate substitutions,
- old_bndr_info = idInfo old_bndr
- new_bndr_info = substIdInfo subst old_bndr_info
+ new_bndr_info = substIdInfo subst (idInfo old_bndr) (idInfo new_bndr)
`setArityInfo` ArityAtLeast (exprArity new_rhs)
- -- At the *binding* site we want to zap the now-out-of-date inline
- -- pragma, in case the expression is simplified a second time.
- -- This has already been done in new_bndr, so we get it from there
- binding_site_id = new_bndr `setIdInfo`
- (new_bndr_info `setInlinePragInfo` getInlinePragma new_bndr)
+ -- At the *binding* site we use the new binder info
+ binding_site_id = new_bndr `setIdInfo` new_bndr_info
- -- At the occurrence sites we want to know the unfolding,
- -- We want the occurrence info of the *original*, which is already
- -- in new_bndr_info
+ -- At the *occurrence* sites we want to know the unfolding
+ -- We also want the occurrence info of the *original*
occ_site_id = new_bndr `setIdInfo`
- (new_bndr_info `setUnfoldingInfo` mkUnfolding new_rhs)
+ (new_bndr_info `setUnfoldingInfo` mkUnfolding new_rhs
+ `setInlinePragInfo` getInlinePragma old_bndr)
in
- modifyInScope occ_site_id thing_inside `thenSmpl` \ stuff ->
- returnSmpl (addBind (NonRec binding_site_id new_rhs) stuff)
+ -- These seqs force the Ids, and hence the IdInfos, and hence any
+ -- inner substitutions
+ binding_site_id `seq`
+ occ_site_id `seq`
+
+ (modifyInScope occ_site_id thing_inside `thenSmpl` \ stuff ->
+ returnSmpl (addBind (NonRec binding_site_id new_rhs) stuff))
\end{code}
@@ -672,8 +680,7 @@ splitFloats floats rhs
\begin{code}
simplVar var cont
- = freeTick LeafVisit `thenSmpl_`
- getSubst `thenSmpl` \ subst ->
+ = getSubst `thenSmpl` \ subst ->
case lookupSubst subst var of
Just (DoneEx (Var v)) -> zapSubstEnv (simplVar v cont)
Just (DoneEx e) -> zapSubstEnv (simplExprF e cont)
@@ -697,12 +704,17 @@ simplVar var cont
in
getBlackList `thenSmpl` \ black_list ->
getInScope `thenSmpl` \ in_scope ->
- completeCall black_list in_scope var' cont
+ completeCall black_list in_scope var var' cont
---------------------------------------------------------
-- Dealing with a call
-completeCall black_list_fn in_scope var cont
+completeCall black_list_fn in_scope orig_var var cont
+-- For reasons I'm not very clear about, it's important *not* to plug 'var',
+-- which is replete with an inlining in its IdInfo, into the resulting expression
+-- Doing so results in a significant space leak.
+-- Instead we pass orig_var, which has no inlinings etc.
+
-- Look for rules or specialisations that match
-- Do this *before* trying inlining because some functions
-- have specialisations *and* are strict; we don't want to
@@ -717,7 +729,7 @@ completeCall black_list_fn in_scope var cont
-- thing, but perhaps we want to inline it anyway
| maybeToBool maybe_inline
= tick (UnfoldingDone var) `thenSmpl_`
- zapSubstEnv (completeInlining var unf_template discard_inline_cont)
+ zapSubstEnv (completeInlining orig_var unf_template discard_inline_cont)
-- The template is already simplified, so don't re-substitute.
-- This is VITAL. Consider
-- let x = e in
@@ -730,7 +742,7 @@ completeCall black_list_fn in_scope var cont
| otherwise -- Neither rule nor inlining
-- Use prepareArgs to use function strictness
= prepareArgs (ppr var) (idType var) (get_str var) cont $ \ args' cont' ->
- rebuild (mkApps (Var var) args') cont'
+ rebuild (mkApps (Var orig_var) args') cont'
where
get_str var = case getIdStrictness var of
@@ -835,6 +847,7 @@ prepareArgs pp_fun orig_fun_ty (fun_demands, result_bot) orig_cont thing_inside
ty_arg' = substTy (mkSubst in_scope se) ty_arg
res_ty = applyTy fun_ty ty_arg'
in
+ seqType ty_arg' `seq`
go (Type ty_arg' : acc) ds res_ty cont
-- Value argument
diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs
index 16f261f11be3487af3894bda505de1e705800d57..f185c19b6a2aadc5e194e21035e0e98016a1e9bb 100644
--- a/ghc/compiler/simplStg/StgVarInfo.lhs
+++ b/ghc/compiler/simplStg/StgVarInfo.lhs
@@ -276,9 +276,9 @@ varsExpr (StgCon con args res_ty)
varsAtoms args `thenLne` \ (args', args_fvs) ->
returnLne (StgCon con args' res_ty, args_fvs, getFVSet args_fvs)
-varsExpr (StgSCC label expr)
+varsExpr (StgSCC cc expr)
= varsExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
- returnLne (StgSCC label expr2, fvs, escs) )
+ returnLne (StgSCC cc expr2, fvs, escs) )
\end{code}
Cases require a little more real work.
diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index cf9623f2f6cf752941894968f036e70896064ca3..970f04f9ece7120519cfd7e76ffe9cf8eb53c787 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -20,21 +20,21 @@ import StgSyn -- output
import CoreUtils ( coreExprType )
import SimplUtils ( findDefault )
import CostCentre ( noCCS )
-import Id ( Id, mkSysLocal, idType, getIdStrictness, idUnique, isExportedId,
+import Id ( Id, mkSysLocal, idType, getIdStrictness, idUnique, isExportedId, mkVanillaId,
externallyVisibleId, setIdUnique, idName, getIdDemandInfo, setIdType
)
import Var ( Var, varType, modifyIdInfo )
-import IdInfo ( setDemandInfo, StrictnessInfo(..) )
+import IdInfo ( setDemandInfo, StrictnessInfo(..), zapIdInfoForStg )
import UsageSPUtils ( primOpUsgTys )
import DataCon ( DataCon, dataConName, dataConId )
import Demand ( Demand, isStrict, wwStrict, wwLazy )
-import Name ( Name, nameModule, isLocallyDefinedName )
+import Name ( Name, nameModule, isLocallyDefinedName, setNameUnique )
import Module ( isDynamicModule )
import Const ( Con(..), Literal(..), isLitLitLit, conStrictness, isWHNFCon )
import VarEnv
import PrimOp ( PrimOp(..), primOpUsg, primOpSig )
import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
- UsageAnn(..), tyUsg, applyTy, mkUsgTy, repType )
+ UsageAnn(..), tyUsg, applyTy, mkUsgTy, repType, seqType )
import TysPrim ( intPrimTy )
import UniqSupply -- all of it, really
import Util ( lengthExceeds )
@@ -307,14 +307,17 @@ exprToRhs dem toplev (StgCon (DataCon con) args _)
_ -> False
exprToRhs dem _ expr
- = StgRhsClosure noCCS -- No cost centre (ToDo?)
- stgArgOcc -- safe
+ = upd `seq`
+ StgRhsClosure noCCS -- No cost centre (ToDo?)
+ stgArgOcc -- safe
noSRT -- figure out later
bOGUS_FVs
- (if isOnceDem dem then SingleEntry else Updatable)
- -- HA! Paydirt for "dem"
+ upd
[]
expr
+ where
+ upd = if isOnceDem dem then SingleEntry else Updatable
+ -- HA! Paydirt for "dem"
isDynCon :: DataCon -> Bool
isDynCon con = isDynName (dataConName con)
@@ -404,7 +407,7 @@ Simple cases first
\begin{code}
coreExprToStgFloat env (Var var) dem
- = returnUs ([], StgApp (stgLookup env var) [])
+ = returnUs ([], mkStgApp (stgLookup env var) [])
coreExprToStgFloat env (Let bind body) dem
= coreBindToStg NotTopLevel env bind `thenUs` \ (new_bind, new_env) ->
@@ -455,11 +458,11 @@ coreExprToStgFloat env expr@(Lam _ _) dem
case stg_body' of
StgLam ty lam_bndrs lam_body ->
-- If the body reduced to a lambda too, join them up
- returnUs ([], StgLam expr_ty (binders' ++ lam_bndrs) lam_body)
+ returnUs ([], mkStgLam expr_ty (binders' ++ lam_bndrs) lam_body)
other ->
-- Body didn't reduce to a lambda, so return one
- returnUs ([], StgLam expr_ty binders' stg_body')
+ returnUs ([], mkStgLam expr_ty binders' stg_body')
\end{code}
@@ -488,7 +491,7 @@ coreExprToStgFloat env expr@(App _ _) dem
(Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if
-- there are no arguments.
returnUs (arg_floats,
- StgApp (stgLookup env fun_id) stg_args)
+ mkStgApp (stgLookup env fun_id) stg_args)
(non_var_fun, []) -> -- No value args, so recurse into the function
ASSERT( null arg_floats )
@@ -498,7 +501,7 @@ coreExprToStgFloat env expr@(App _ _) dem
newStgVar (coreExprType fun) `thenUs` \ fun_id ->
coreExprToStgFloat env fun onceDem `thenUs` \ (fun_floats, stg_fun) ->
returnUs (NonRecF fun_id stg_fun onceDem fun_floats : arg_floats,
- StgApp fun_id stg_args)
+ mkStgApp fun_id stg_args)
where
-- Collect arguments and demands (*in reverse order*)
@@ -557,6 +560,7 @@ speed.
\begin{code}
coreExprToStgFloat env expr@(Con con args) dem
= let
+ expr_ty = coreExprType expr
(stricts,_) = conStrictness con
onces = case con of
DEFAULT -> panic "coreExprToStgFloat: DEFAULT"
@@ -586,7 +590,7 @@ coreExprToStgFloat env expr@(Con con args) dem
_ -> returnUs con
) `thenUs` \ con' ->
- returnUs (arg_floats, StgCon con' stg_atoms (coreExprType expr))
+ returnUs (arg_floats, mkStgCon con' stg_atoms expr_ty)
\end{code}
@@ -654,7 +658,7 @@ coreExprToStgFloat env
= coreExprToStgFloat env scrut (bdrDem bndr) `thenUs` \ (binds, scrut') ->
newEvaldLocalId env bndr `thenUs` \ (env', bndr') ->
coreExprToStg env' default_rhs dem `thenUs` \ default_rhs' ->
- returnUs (binds, mkStgCase scrut' bndr' (StgPrimAlts (idType bndr) [] (StgBindDefault default_rhs')))
+ returnUs (binds, mkStgCase scrut' bndr' (StgPrimAlts (idType bndr') [] (StgBindDefault default_rhs')))
where
(other_alts, maybe_default) = findDefault alts
Just default_rhs = maybe_default
@@ -676,16 +680,17 @@ coreExprToStgFloat env (Case scrut bndr alts) dem
| prim_case
= default_to_stg env deflt `thenUs` \ deflt' ->
mapUs (prim_alt_to_stg env) alts `thenUs` \ alts' ->
- returnUs (StgPrimAlts scrut_ty alts' deflt')
+ returnUs (mkStgPrimAlts scrut_ty alts' deflt')
| otherwise
= default_to_stg env deflt `thenUs` \ deflt' ->
mapUs (alg_alt_to_stg env) alts `thenUs` \ alts' ->
- returnUs (StgAlgAlts scrut_ty alts' deflt')
+ returnUs (mkStgAlgAlts scrut_ty alts' deflt')
alg_alt_to_stg env (DataCon con, bs, rhs)
- = coreExprToStg env rhs dem `thenUs` \ stg_rhs ->
- returnUs (con, filter isId bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
+ = newLocalIds NotTopLevel env (filter isId bs) `thenUs` \ (env', stg_bs) ->
+ coreExprToStg env' rhs dem `thenUs` \ stg_rhs ->
+ returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs)
-- NB the filter isId. Some of the binders may be
-- existential type variables, which STG doesn't care about
@@ -726,10 +731,12 @@ Invent a fresh @Id@:
newStgVar :: Type -> UniqSM Id
newStgVar ty
= getUniqueUs `thenUs` \ uniq ->
+ seqType ty `seq`
returnUs (mkSysLocal SLIT("stg") uniq ty)
\end{code}
\begin{code}
+{- Now redundant, I believe
-- we overload the demandInfo field of an Id to indicate whether the Id is definitely
-- evaluated or not (i.e. whether it is a case binder). This can be used to eliminate
-- some redundant cases (c.f. dataToTag# above).
@@ -741,22 +748,35 @@ newEvaldLocalId env id
new_env = extendVarEnv env id id'
in
returnUs (new_env, id')
+-}
+newEvaldLocalId env id = newLocalId NotTopLevel env id
newLocalId TopLevel env id
- = returnUs (env, id)
-- Don't clone top-level binders. MkIface relies on their
-- uniques staying the same, so it can snaffle IdInfo off the
-- STG ids to put in interface files.
+ = let
+ name = idName id
+ ty = idType id
+ in
+ name `seq`
+ seqType ty `seq`
+ returnUs (env, mkVanillaId name ty)
+
newLocalId NotTopLevel env id
= -- Local binder, give it a new unique Id.
getUniqueUs `thenUs` \ uniq ->
let
- id' = setIdUnique id uniq
- new_env = extendVarEnv env id id'
+ name = idName id
+ ty = idType id
+ new_id = mkVanillaId (setNameUnique name uniq) ty
+ new_env = extendVarEnv env id new_id
in
- returnUs (new_env, id')
+ name `seq`
+ seqType ty `seq`
+ returnUs (new_env, new_id)
newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
newLocalIds top_lev env []
@@ -768,6 +788,23 @@ newLocalIds top_lev env (b:bs)
\end{code}
+%************************************************************************
+%* *
+\subsection{Building STG syn}
+%* *
+%************************************************************************
+
+\begin{code}
+mkStgAlgAlts ty alts deflt = seqType ty `seq` StgAlgAlts ty alts deflt
+mkStgPrimAlts ty alts deflt = seqType ty `seq` StgPrimAlts ty alts deflt
+mkStgCon con args ty = seqType ty `seq` StgCon con args ty
+mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body
+
+mkStgApp :: Id -> [StgArg] -> StgExpr
+mkStgApp fn args = fn `seq` StgApp fn args
+ -- Force the lookup
+\end{code}
+
\begin{code}
-- Stg doesn't have a lambda *expression*,
deStgLam (StgLam ty bndrs body) = mkStgLamExpr ty bndrs body
@@ -776,7 +813,7 @@ deStgLam expr = returnUs expr
mkStgLamExpr ty bndrs body
= ASSERT( not (null bndrs) )
newStgVar ty `thenUs` \ fn ->
- returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn []))
+ returnUs (StgLet (StgNonRec fn lam_closure) (mkStgApp fn []))
where
lam_closure = StgRhsClosure noCCS
stgArgOcc
diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs
index 631218afaf0e00dcc84f3f005e218292c1c6af16..11ca9448dcb738f892e842d8eabb7341323a8c62 100644
--- a/ghc/compiler/stgSyn/StgLint.lhs
+++ b/ghc/compiler/stgSyn/StgLint.lhs
@@ -224,6 +224,7 @@ lintAlgAlt scrut_ty (con, args, _, rhs)
Just (tycon, tys_applied, cons) ->
let
arg_tys = dataConArgTys con tys_applied
+ -- This almost certainly does not work for existential constructors
in
checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_`
checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs
index 74155cf58c469e4e4cd61ee0fdefa3b37fd94b4d..8dc733188610a851b658f644e3176a8312cb9ac8 100644
--- a/ghc/compiler/stranal/SaAbsInt.lhs
+++ b/ghc/compiler/stranal/SaAbsInt.lhs
@@ -21,7 +21,7 @@ import CoreUnfold ( Unfolding, maybeUnfoldingTemplate )
import PrimOp ( primOpStrictness )
import Id ( Id, idType, getIdStrictness, getIdUnfolding )
import Const ( Con(..) )
-import DataCon ( dataConTyCon, dataConArgTys )
+import DataCon ( dataConTyCon, splitProductType_maybe )
import IdInfo ( StrictnessInfo(..) )
import Demand ( Demand(..), wwPrim, wwStrict, wwEnum, wwUnpackData,
wwUnpackNew )
@@ -714,25 +714,27 @@ findRecDemand str_fn abs_fn ty
else -- It's strict (or we're pretending it is)!
- case (splitAlgTyConApp_maybe ty) of
+ case splitProductType_maybe ty of
- Nothing -> wwStrict
+ Nothing -> wwStrict -- Could have a test for wwEnum, but
+ -- we don't exploit it yet, so don't bother
- Just (tycon,tycon_arg_tys,[data_con]) | isProductTyCon tycon ->
- -- Non-recursive, single constructor case
- let
- cmpnt_tys = dataConArgTys data_con tycon_arg_tys
- prod_len = length cmpnt_tys
- in
-
- if isNewTyCon tycon then -- A newtype!
- ASSERT( null (tail cmpnt_tys) )
+ Just (tycon,_,data_con,cmpnt_tys) -- Non-recursive, single constructor case
+ | isNewTyCon tycon -- A newtype!
+ -> ASSERT( null (tail cmpnt_tys) )
let
demand = findRecDemand str_fn abs_fn (head cmpnt_tys)
in
wwUnpackNew demand
- else -- A data type!
- let
+
+ | null compt_strict_infos -- A nullary data type
+ -> wwStrict
+
+ | otherwise -- Some other data type
+ -> wwUnpackData compt_strict_infos
+
+ where
+ prod_len = length cmpnt_tys
compt_strict_infos
= [ findRecDemand
(\ cmpnt_val ->
@@ -743,21 +745,7 @@ findRecDemand str_fn abs_fn ty
)
cmpnt_ty
| (cmpnt_ty, i) <- cmpnt_tys `zip` [1..] ]
- in
- if null compt_strict_infos then
- if isEnumerationTyCon tycon then wwEnum else wwStrict
- else
- wwUnpackData compt_strict_infos
-
- Just (tycon,_,_) ->
- -- Multi-constr data types, *or* an abstract data
- -- types, *or* things we don't have a way of conveying
- -- the info over module boundaries (class ops,
- -- superdict sels, dfns).
- if isEnumerationTyCon tycon then
- wwEnum
- else
- wwStrict
+
where
is_numeric_type ty
= case (splitAlgTyConApp_maybe ty) of -- NB: duplicates stuff done above
diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs
index 4eefd47a1907025389f319a27ccba8f84b887244..c739cc9ab17ef863424bd81221d1b23e38f028c8 100644
--- a/ghc/compiler/stranal/WwLib.lhs
+++ b/ghc/compiler/stranal/WwLib.lhs
@@ -19,7 +19,7 @@ import Id ( Id, idType, mkSysLocal, getIdDemandInfo, setIdDemandInfo,
)
import IdInfo ( CprInfo(..), noCprInfo, vanillaIdInfo )
import Const ( Con(..), DataCon )
-import DataCon ( dataConArgTys )
+import DataCon ( splitProductType_maybe )
import Demand ( Demand(..) )
import PrelInfo ( realWorldPrimId, aBSENT_ERROR_ID )
import TysPrim ( realWorldStatePrimTy )
@@ -27,7 +27,7 @@ import TysWiredIn ( unboxedTupleCon, unboxedTupleTyCon )
import Type ( isUnLiftedType, mkTyVarTys, mkTyVarTy, mkFunTys,
splitForAllTys, splitFunTys, splitFunTysN,
splitAlgTyConApp_maybe, splitAlgTyConApp,
- mkTyConApp, newTypeRep, isNewType,
+ mkTyConApp, splitNewType_maybe,
Type
)
import TyCon ( isNewTyCon,
@@ -312,16 +312,10 @@ where R' is the representation type for R.
\begin{code}
mkWWcoerce body_ty
- | not (isNewType body_ty)
- = (id, id)
-
- | otherwise
- = (wrap_fn . mkNote (Coerce body_ty rep_ty),
- mkNote (Coerce rep_ty body_ty) . work_fn)
- where
- (tycon, args, _) = splitAlgTyConApp body_ty
- rep_ty = newTypeRep tycon args
- (wrap_fn, work_fn) = mkWWcoerce rep_ty
+ = case splitNewType_maybe body_ty of
+ Nothing -> (id, id)
+ Just rep_ty -> (mkNote (Coerce body_ty rep_ty),
+ mkNote (Coerce rep_ty body_ty))
\end{code}
@@ -396,21 +390,7 @@ mk_ww (arg : ds)
mk_unpk_case new_or_data arg unpk_args data_con arg_tycon . wrap_fn,
work_fn . mk_pk_let new_or_data arg data_con tycon_arg_tys unpk_args)
where
- inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys
- (arg_tycon, tycon_arg_tys, data_con)
- = case (splitAlgTyConApp_maybe (idType arg)) of
-
- Just (arg_tycon, tycon_arg_tys, [data_con]) ->
- -- The main event: a single-constructor data type
- (arg_tycon, tycon_arg_tys, data_con)
-
- Just (_, _, data_cons) ->
- pprPanic "mk_ww_arg_processing:"
- (text "not one constr (interface files not consistent/up to date?)"
- $$ (ppr arg <+> ppr (idType arg)))
-
- Nothing ->
- panic "mk_ww_arg_processing: not datatype"
+ (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys) = splitProductType "mk_ww" (idType arg)
-- Other cases
other_demand ->
@@ -512,7 +492,7 @@ mk_cpr_case (ty, cpr_info@(CPRInfo ci_args))
in
returnUs (id_id, new_tup, new_exp_case)
where
- (data_con, tycon, tycon_arg_tys, inst_con_arg_tys) = splitType "mk_cpr_case" ty
+ (tycon, tycon_arg_tys, data_con, inst_con_arg_tys) = splitProductType "mk_cpr_case" ty
from_type = head inst_con_arg_tys
-- if coerced from a function 'look through' to find result type
target_of_from_type = (snd.splitFunTys.snd.splitForAllTys) from_type
@@ -570,29 +550,16 @@ mk_cpr_let (ty, cpr_info@(CPRInfo ci_args))
in
returnUs (id_id, new_tup, new_exp)
where
- (data_con, tycon, tycon_arg_tys, inst_con_arg_tys) = splitType "mk_cpr_let" ty
+ (tycon, tycon_arg_tys, data_con, inst_con_arg_tys) = splitProductType "mk_cpr_let" ty
from_type = head inst_con_arg_tys
-- if coerced from a function 'look through' to find result type
target_of_from_type = (snd.splitFunTys.snd.splitForAllTys) from_type
-splitType :: String -> Type -> (DataCon, TyCon, [Type], [Type])
-splitType fname ty = (data_con, tycon, tycon_arg_tys, dataConArgTys data_con tycon_arg_tys)
- where
- (data_con, tycon, tycon_arg_tys)
- = case (splitAlgTyConApp_maybe ty) of
- Just (arg_tycon, tycon_arg_tys, [data_con]) ->
- -- The main event: a single-constructor data type
- (data_con, arg_tycon, tycon_arg_tys)
-
- Just (_, _, data_cons) ->
- pprPanic (fname ++ ":")
- (text "not one constr (interface files not consistent/up to date?)"
- $$ ppr ty)
-
- Nothing ->
- pprPanic (fname ++ ":")
- (text "not a datatype" $$ ppr ty)
+splitProductType :: String -> Type -> (TyCon, [Type], DataCon, [Type])
+splitProductType fname ty = case splitProductType_maybe ty of
+ Just stuff -> stuff
+ Nothing -> pprPanic (fname ++ ": not a product") (ppr ty)
\end{code}
diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index b9b308bc4c37263fd205b147c291de2e57de6f59..4fb993e868ea308e1d48970e66560deae90d3466 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -33,7 +33,7 @@ import HsTypes ( HsTyVar, getTyVarName )
import Id ( mkUserLocal, isDataConId_maybe )
import MkId ( mkSpecPragmaId )
import Var ( TyVar, Id, setVarName,
- idType, setIdInfo, idInfo, tyVarKind
+ idType, lazySetIdInfo, idInfo, tyVarKind
)
import TcType ( TcType, TcTyVar, TcTyVarSet, TcThetaType,
tcInstTyVars, zonkTcTyVars,
@@ -396,7 +396,7 @@ tcAddImportedIdInfo unf_env id
-- have explicit local definitions, so we get a black hole!
= id
| otherwise
- = id `setIdInfo` new_info
+ = id `lazySetIdInfo` new_info
-- The Id must be returned without a data dependency on maybe_id
where
new_info = -- pprTrace "tcAdd" (ppr id) $
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index a27b3b0638b3cae6dd818f0470e76af85d1393f7..b9960e6c2df44397461cf33d35106a1487bc3e72 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -377,9 +377,9 @@ tcMonoExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
\end{code}
\begin{code}
-tcMonoExpr (HsSCC label expr) res_ty
+tcMonoExpr (HsSCC lbl expr) res_ty
= tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
- returnTc (HsSCC label expr', lie)
+ returnTc (HsSCC lbl expr', lie)
tcMonoExpr (HsLet binds expr) res_ty
= tcBindsAndThen
@@ -982,7 +982,7 @@ Errors and contexts
Mini-utils:
\begin{code}
pp_nest_hang :: String -> SDoc -> SDoc
-pp_nest_hang label stuff = nest 2 (hang (text label) 4 stuff)
+pp_nest_hang lbl stuff = nest 2 (hang (text lbl) 4 stuff)
\end{code}
Boring and alphabetical:
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 41e44c5a4e9709268f267f79101385daf0aa3c20..98c4a903c8b1c8ab1496fe184e3be68cdcb9c470 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -41,7 +41,7 @@ import HsSyn -- oodles of it
-- others:
import Id ( idName, idType, setIdType, omitIfaceSigForId, Id )
-import DataCon ( DataCon, dataConArgTys )
+import DataCon ( DataCon, splitProductType_maybe )
import TcEnv ( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv,
ValueEnv, TcId, tcInstId
)
@@ -138,13 +138,11 @@ DsCCall.lhs.
\begin{code}
maybeBoxedPrimType :: Type -> Maybe (DataCon, Type)
maybeBoxedPrimType ty
- = case splitAlgTyConApp_maybe ty of -- Data type,
- Just (tycon, tys_applied, [data_con]) | isDataTyCon tycon -- with exactly one constructor
- -> case (dataConArgTys data_con tys_applied) of
- [data_con_arg_ty] -- Applied to exactly one type,
- | isUnLiftedType data_con_arg_ty -- which is primitive
- -> Just (data_con, data_con_arg_ty)
- other_cases -> Nothing
+ = case splitProductType_maybe ty of -- Product data type
+ Just (tycon, tys_applied, data_con, [data_con_arg_ty]) -- constr has one arg
+ | isUnLiftedType data_con_arg_ty -- which is primitive
+ -> Just (data_con, data_con_arg_ty)
+
other_cases -> Nothing
\end{code}
@@ -453,9 +451,9 @@ zonkExpr (CCall fun args may_gc is_casm result_ty)
zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
-zonkExpr (HsSCC label expr)
+zonkExpr (HsSCC lbl expr)
= zonkExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (HsSCC label new_expr)
+ returnNF_Tc (HsSCC lbl new_expr)
zonkExpr (TyLam tyvars expr)
= mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 2f14a7b40d1d36be033708832e789524ce9d37c0..f615dec8160f58c2ecf3828608260594a8d429bf 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -39,7 +39,7 @@ import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
import CmdLineOpts ( opt_GlasgowExts, opt_AllowUndecidableInstances )
import Class ( classBigSig, Class )
import Var ( idName, idType, Id, TyVar )
-import DataCon ( isNullaryDataCon, dataConArgTys, dataConId )
+import DataCon ( isNullaryDataCon, splitProductType_maybe, dataConId )
import Maybes ( maybeToBool, catMaybes, expectJust )
import MkId ( mkDictFunId )
import Module ( ModuleName )
@@ -564,16 +564,13 @@ ccallable_type ty = isUnLiftedType ty || -- Allow CCallable Int# etc
ty == stringTy ||
byte_arr_thing
where
- byte_arr_thing = case splitAlgTyConApp_maybe ty of
- Just (tycon, ty_args, [data_con]) | isDataTyCon tycon ->
- length data_con_arg_tys == 2 &&
+ byte_arr_thing = case splitProductType_maybe ty of
+ Just (tycon, ty_args, data_con, [data_con_arg_ty1, data_con_arg_ty2]) ->
maybeToBool maybe_arg2_tycon &&
(arg2_tycon == byteArrayPrimTyCon ||
arg2_tycon == mutableByteArrayPrimTyCon)
where
- data_con_arg_tys = dataConArgTys data_con ty_args
- (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
- maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2
+ maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2
Just (arg2_tycon,_) = maybe_arg2_tycon
other -> False
diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index 49cf2bcd5b4ab434ef00adb4bfa682d418cc1358..28eaddfc903f9c14e94f39f54e57f90be0366db0 100644
--- a/ghc/compiler/types/TyCon.lhs
+++ b/ghc/compiler/types/TyCon.lhs
@@ -273,10 +273,10 @@ isDataTyCon other = False
isNewTyCon (AlgTyCon {algTyConFlavour = NewType}) = True
isNewTyCon other = False
--- A "product" tycon is non-recursive and has one constructor,
+-- A "product" tycon is non-recursive and has one constructor, and is *not* an unboxed tuple
-- whether DataType or NewType
isProductTyCon (AlgTyCon {dataCons = [c], algTyConRec = NonRecursive}) = True
-isProductTyCon (TupleTyCon {}) = True
+isProductTyCon (TupleTyCon { tyConBoxed = boxed }) = boxed
isProductTyCon other = False
isSynTyCon (SynTyCon {}) = True
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index d77827790a12b6fd85791d281754807eae4983aa..93f2ff678c2beb9029bad3fab91ba1ae066111c8 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -33,7 +33,7 @@ module Type (
splitAlgTyConApp_maybe, splitAlgTyConApp,
mkDictTy, splitDictTy_maybe, isDictTy,
- mkSynTy, isSynTy, deNoteType, repType, newTypeRep,
+ mkSynTy, isSynTy, deNoteType, repType, splitNewType_maybe,
mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg,
@@ -57,7 +57,11 @@ module Type (
tidyType, tidyTypes,
tidyOpenType, tidyOpenTypes,
tidyTyVar, tidyTyVars,
- tidyTopType
+ tidyTopType,
+
+ -- Seq
+ seqType, seqTypes
+
) where
#include "HsVersions.h"
@@ -97,7 +101,7 @@ import PrimRep ( PrimRep(..), isFollowableRep )
import Unique -- quite a few *Keys
import Util ( thenCmp, mapAccumL, seqList, ($!) )
import Outputable
-
+import UniqSet ( sizeUniqSet ) -- Should come via VarSet
\end{code}
%************************************************************************
@@ -543,6 +547,7 @@ isDictTy other = False
mkSynTy syn_tycon tys
= ASSERT( isSynTyCon syn_tycon )
ASSERT( isNotUsgTy body )
+ ASSERT( length tyvars == length tys )
NoteTy (SynNote (TyConApp syn_tycon tys))
(substTy (mkTyVarSubst tyvars tys) body)
where
@@ -587,13 +592,24 @@ interested in newtypes anymore.
repType :: Type -> Type
repType (NoteTy _ ty) = repType ty
repType (ForAllTy _ ty) = repType ty
-repType (TyConApp tc tys) | isNewTyCon tc = repType (newTypeRep tc tys)
+repType (TyConApp tc tys) | isNewTyCon tc = repType (new_type_rep tc tys)
repType other_ty = other_ty
-newTypeRep :: TyCon -> [Type] -> Type
+splitNewType_maybe :: Type -> Maybe Type
+-- Find the representation of a newtype, if it is one
+splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty
+splitNewType_maybe (TyConApp tc tys) | isNewTyCon tc = case splitNewType_maybe rep_ty of
+ Just rep_ty' -> Just rep_ty'
+ Nothing -> Just rep_ty
+ where
+ rep_ty = new_type_rep tc tys
+
+splitNewType_maybe other = Nothing
+
+new_type_rep :: TyCon -> [Type] -> Type
-- The representation type for (T t1 .. tn), where T is a newtype
-- Looks through one layer only
-newTypeRep tc tys
+new_type_rep tc tys
= ASSERT( isNewTyCon tc )
case splitFunTy_maybe (applyTys (dataConType (head (tyConDataCons tc))) tys) of
Just (rep_ty, _) -> rep_ty
@@ -1068,3 +1084,28 @@ cmpTy ty1 ty2
\end{code}
+%************************************************************************
+%* *
+\subsection{Sequencing on types
+%* *
+%************************************************************************
+
+\begin{code}
+seqType :: Type -> ()
+seqType (TyVarTy tv) = tv `seq` ()
+seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2
+seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2
+seqType (NoteTy note t2) = seqNote note `seq` seqType t2
+seqType (TyConApp tc tys) = tc `seq` seqTypes tys
+seqType (ForAllTy tv ty) = tv `seq` seqType ty
+
+seqTypes :: [Type] -> ()
+seqTypes [] = ()
+seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
+
+seqNote :: TyNote -> ()
+seqNote (SynNote ty) = seqType ty
+seqNote (FTVNote set) = sizeUniqSet set `seq` ()
+seqNote (UsgNote usg) = usg `seq` ()
+\end{code}
+
diff --git a/ghc/compiler/utils/Digraph.lhs b/ghc/compiler/utils/Digraph.lhs
index b904fff79373831d251e4fbf7ac545176c49442e..3196e6eefeb2d15e0da0b271d334920b06fe7370 100644
--- a/ghc/compiler/utils/Digraph.lhs
+++ b/ghc/compiler/utils/Digraph.lhs
@@ -377,13 +377,13 @@ path g v w = w `elem` (reachable g v)
\begin{code}
bcc :: Graph -> Forest [Vertex]
-bcc g = (concat . map bicomps . map (label g dnum)) forest
+bcc g = (concat . map bicomps . map (do_label g dnum)) forest
where forest = dff g
dnum = preArr (bounds g) forest
-label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int)
-label g dnum (Node v ts) = Node (v,dnum!v,lv) us
- where us = map (label g dnum) ts
+do_label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int)
+do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us
+ where us = map (do_label g dnum) ts
lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v]
++ [lu | Node (u,du,lu) xs <- us])
diff --git a/ghc/compiler/utils/StringBuffer.lhs b/ghc/compiler/utils/StringBuffer.lhs
index 2b22939db0aecb428ee8462c842347ce44223245..f70500a7c09c52c157d4db7a914c6ce8dec7ddf2 100644
--- a/ghc/compiler/utils/StringBuffer.lhs
+++ b/ghc/compiler/utils/StringBuffer.lhs
@@ -212,7 +212,10 @@ slurpFileExpandTabs fname = do
trySlurp :: Handle -> Int -> Addr -> IO (Addr, Int)
trySlurp handle sz_i chunk =
-#if __GLASGOW_HASKELL__ >= 303
+#if __GLASGOW_HASKELL__ == 303
+ wantReadableHandle "hGetChar" handle >>= \ handle_ ->
+ let fo = haFO__ handle_ in
+#elif __GLASGOW_HASKELL__ > 303
wantReadableHandle "hGetChar" handle $ \ handle_ ->
let fo = haFO__ handle_ in
#else
@@ -276,7 +279,7 @@ reAllocMem :: Addr -> Int -> IO Addr
reAllocMem ptr sz = do
chunk <- _ccall_ realloc ptr sz
if chunk == nullAddr
-#if __GLASGOW_HASKELL__ < 303
+#ifndef __HASKELL98__
then fail (userError "reAllocMem")
#else
then fail "reAllocMem"