Commit 4e7d56fd authored by simonpj's avatar simonpj

[project @ 1999-07-14 14:40:20 by simonpj]

Main things:

* Add splitProductType_maybe to DataCon.lhs, with type
  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

  Then use it in many places (e.g. worker-wrapper places) instead
  of a pile of junk

* Clean up various uses of dataConArgTys, which were plain wrong because
  they weren't passed the existential type arguments.  Most of these calls
  are eliminated by using splitProductType_maybe above.  I hope I correctly
  squashed the others. This fixes a bug that Meurig's programs showed up.

    module FailGHC (killSustainer) where
    import Weak
    import IOExts

    data Sustainer = forall a . Sustainer (IORef (Maybe a)) (IO ())

    killSustainer :: Sustainer -> IO ()
    killSustainer (Sustainer _ act) = act

  The above program used to kill the compiler.

* A fairly concerted attack on the Dreaded Space Leak.
	- Add Type.seqType, CoreSyn.seqExpr, CoreSyn.seqRules

	- Add some seq'ing when building Ids and IdInfos
		These reduce the space usage a lot

	- Add CoreSyn.coreBindsSize, which is pretty strict in the program,
		and call it when we have -dshow-passes.

	- Do not put the inlining in an Id that is being plugged into
		the result-expression of the simplifier.  This cures
		a the 'wedge' in the space profile for reasons I don't understand fully

  Together, these things reduce the max space usage when compiling PrelNum from
  17M to about 7Mbytes.

  I think there are now *too many* seqs, and they waste work, but I don't have
  time to find which ones.

  Furthermore, we aren't done. For some reason, some of the stuff allocated by
  the simplifier makes it through all during code generation and I don't see why.
  There's a should-be-unnecessary call to coreBindsSize in Main.main which
  zaps some, but not all of this space.

  -dshow-passes reduces space usage a bit, but I don't think it should really.

  All the measurements were made on a compiler compiled with profiling by
  GHC 3.03.    I hope they carry over to other builds!

* One trivial thing: changed all variables 'label' to 'lbl', becuase the
  former is a keyword with -fglagow-exts in GHC 3.03 (which I was compiling with).
  Something similar in StringBuffer.
parent 0b127ebe
......@@ -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) ->
......
......@@ -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
......
......@@ -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}
......@@ -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}
......
......@@ -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)
......
_interface_ IdInfo 1
_exports_
IdInfo IdInfo ;
IdInfo IdInfo seqIdInfo ;
_declarations_
1 data IdInfo ;
1 seqIdInfo _:_ IdInfo -> PrelBase.() ;;
__interface IdInfo 1 0 where
__export IdInfo IdInfo ;
__export IdInfo IdInfo seqIdInfo ;
1 data IdInfo ;
1 seqIdInfo :: IdInfo -> PrelBase.Z0T ;
......@@ -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}
......
%
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
......
......@@ -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