Commit 23f40f0e authored by simonpj's avatar simonpj

[project @ 2004-09-30 10:35:15 by simonpj]

------------------------------------
	Add Generalised Algebraic Data Types
	------------------------------------

This rather big commit adds support for GADTs.  For example,

    data Term a where
 	  Lit :: Int -> Term Int
	  App :: Term (a->b) -> Term a -> Term b
	  If  :: Term Bool -> Term a -> Term a
	  ..etc..

    eval :: Term a -> a
    eval (Lit i) = i
    eval (App a b) = eval a (eval b)
    eval (If p q r) | eval p    = eval q
    		    | otherwise = eval r


Lots and lots of of related changes throughout the compiler to make
this fit nicely.

One important change, only loosely related to GADTs, is that skolem
constants in the typechecker are genuinely immutable and constant, so
we often get better error messages from the type checker.  See
TcType.TcTyVarDetails.

There's a new module types/Unify.lhs, which has purely-functional
unification and matching for Type. This is used both in the typechecker
(for type refinement of GADTs) and in Core Lint (also for type refinement).
parent 9b6858cb
......@@ -64,23 +64,16 @@ name = Util.global (value) :: IORef (ty); \
#define ASSERT(e) if (not (e)) then (assertPanic __FILE__ __LINE__) else
#define ASSERT2(e,msg) if (not (e)) then (assertPprPanic __FILE__ __LINE__ (msg)) else
#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg))
#define ASSERTM(e) ASSERT(e) do
#define ASSERTM(mbool) do { bool <- mbool; ASSERT(bool) return () }
#define ASSERTM2(mbool,msg) do { bool <- mbool; ASSERT2(bool,msg) return () }
#else
#define ASSERT(e) if False then error "ASSERT" else
#define ASSERT2(e,msg) if False then error "ASSERT2" else
#define ASSERTM(e)
#define ASSERTM2(e)
#define WARN(e,msg) if False then error "WARN" else
#endif
-- temporary usage assertion control KSW 2000-10
#ifdef DO_USAGES
#define UASSERT(e) ASSERT(e)
#define UASSERT2(e,msg) ASSERT2(e,msg)
#else
#define UASSERT(e)
#define UASSERT2(e,msg)
#endif
-- This #ifndef lets us switch off the "import FastString"
-- when compiling FastString itself
#ifndef COMPILING_FAST_STRING
......
*** unexpected failure for jtod_circint(opt)
New back end thoughts
-----------------------------------------------------------------------------
......
......@@ -2,4 +2,4 @@ module DataCon where
data DataCon
dataConName :: DataCon -> Name.Name
isExistentialDataCon :: DataCon -> GHC.Base.Bool
isVanillaDataCon :: DataCon -> GHC.Base.Bool
This diff is collapsed.
......@@ -90,6 +90,7 @@ import Var ( Id, DictId,
globalIdDetails
)
import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId, mkExportedLocalId )
import TyCon ( FieldLabel, TyCon )
import Type ( Type, typePrimRep, addFreeTyVars, seqType,
splitTyConApp_maybe, PrimRep )
import TysPrim ( statePrimTyCon )
......@@ -106,7 +107,6 @@ import Name ( Name, OccName, nameIsLocalOrFrom,
)
import Module ( Module )
import OccName ( EncodedFS, mkWorkerOcc )
import FieldLabel ( FieldLabel )
import Maybes ( orElse )
import SrcLoc ( SrcLoc )
import Outputable
......@@ -239,13 +239,13 @@ Meanwhile, it is not discarded as dead code.
\begin{code}
recordSelectorFieldLabel :: Id -> FieldLabel
recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel)
recordSelectorFieldLabel id = case globalIdDetails id of
RecordSelId lbl -> lbl
RecordSelId tycon lbl -> (tycon,lbl)
other -> panic "recordSelectorFieldLabel"
isRecordSelector id = case globalIdDetails id of
RecordSelId lbl -> True
RecordSelId _ _ -> True
other -> False
isPrimOpId id = case globalIdDetails id of
......@@ -290,7 +290,7 @@ isImplicitId :: Id -> Bool
-- file, even if it's mentioned in some other interface unfolding.
isImplicitId id
= case globalIdDetails id of
RecordSelId _ -> True
RecordSelId _ _ -> True
FCallId _ -> True
PrimOpId _ -> True
ClassOpId _ -> True
......
......@@ -87,8 +87,8 @@ import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBrea
Activation(..)
)
import DataCon ( DataCon )
import TyCon ( TyCon, FieldLabel )
import ForeignCall ( ForeignCall )
import FieldLabel ( FieldLabel )
import NewDemand
import Outputable
import Maybe ( isJust )
......@@ -230,7 +230,8 @@ an IdInfo.hi-boot, but no Id.hi-boot, and GlobalIdDetails is imported
data GlobalIdDetails
= VanillaGlobal -- Imported from elsewhere, a default method Id.
| RecordSelId FieldLabel -- The Id for a record selector
| RecordSelId TyCon FieldLabel -- The Id for a record selector
| DataConWorkId DataCon -- The Id for a data constructor *worker*
| DataConWrapId DataCon -- The Id for a data constructor *wrapper*
-- [the only reasons we need to know is so that
......@@ -255,7 +256,7 @@ instance Outputable GlobalIdDetails where
ppr (ClassOpId _) = ptext SLIT("[ClassOp]")
ppr (PrimOpId _) = ptext SLIT("[PrimOp]")
ppr (FCallId _) = ptext SLIT("[ForeignCall]")
ppr (RecordSelId _) = ptext SLIT("[RecSel]")
ppr (RecordSelId _ _) = ptext SLIT("[RecSel]")
\end{code}
......
......@@ -7,7 +7,7 @@
module Literal
( Literal(..) -- Exported to ParseIface
, mkMachInt, mkMachWord
, mkMachInt64, mkMachWord64
, mkMachInt64, mkMachWord64, mkStringLit,
, litSize
, litIsDupable, litIsTrivial
, literalType,
......@@ -35,6 +35,7 @@ import FastTypes
import FastString
import Binary
import UnicodeUtil ( stringToUtf8 )
import Ratio ( numerator )
import FastString ( uniqueOfFS, lengthFS )
import DATA_INT ( Int8, Int16, Int32 )
......@@ -204,6 +205,9 @@ mkMachWord x = -- ASSERT2( inWordRange x, integer x )
mkMachInt64 x = MachInt64 x
mkMachWord64 x = MachWord64 x
mkStringLit :: String -> Literal
mkStringLit s = MachStr (mkFastString (stringToUtf8 s))
inIntRange, inWordRange :: Integer -> Bool
inIntRange x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT
inWordRange x = x >= 0 && x <= tARGET_MAX_WORD
......
This diff is collapsed.
......@@ -326,37 +326,40 @@ pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ})
Internal -> pprInternal sty uniq occ
pprExternal sty uniq mod occ is_wired is_builtin
| codeStyle sty = ppr mod_name <> char '_' <> pprOccName occ
| codeStyle sty = ppr mod_name <> char '_' <> ppr_occ_name occ
-- In code style, always qualify
-- ToDo: maybe we could print all wired-in things unqualified
-- in code style, to reduce symbol table bloat?
| debugStyle sty = sep [ppr mod_name <> dot <> pprOccName occ,
hsep [text "{-"
, if is_wired then ptext SLIT("(w)") else empty
, pprUnique uniq
-- (overkill) , case mb_p of
-- Nothing -> empty
-- Just n -> brackets (ppr n)
, text "-}"]]
| BuiltInSyntax <- is_builtin = pprOccName occ
| debugStyle sty = ppr mod_name <> dot <> ppr_occ_name occ
<> braces (hsep [if is_wired then ptext SLIT("(w)") else empty,
text (briefOccNameFlavour occ),
pprUnique uniq])
| BuiltInSyntax <- is_builtin = ppr_occ_name occ
-- never qualify builtin syntax
| unqualStyle sty mod_name occ = pprOccName occ
| otherwise = ppr mod_name <> dot <> pprOccName occ
| unqualStyle sty mod_name occ = ppr_occ_name occ
| otherwise = ppr mod_name <> dot <> ppr_occ_name occ
where
mod_name = moduleName mod
pprInternal sty uniq occ
| codeStyle sty = pprUnique uniq
| debugStyle sty = pprOccName occ <> text "{-" <> pprUnique uniq <> text "-}"
| otherwise = pprOccName occ -- User style
| debugStyle sty = ppr_occ_name occ <> braces (hsep [text (briefOccNameFlavour occ),
pprUnique uniq])
| otherwise = ppr_occ_name occ -- User style
-- Like Internal, except that we only omit the unique in Iface style
pprSystem sty uniq occ
| codeStyle sty = pprUnique uniq
| otherwise = pprOccName occ <> char '_' <> pprUnique uniq
| debugStyle sty = ppr_occ_name occ <> char '_' <> pprUnique uniq
<> braces (text (briefOccNameFlavour occ))
| otherwise = ppr_occ_name occ <> char '_' <> pprUnique uniq
-- If the tidy phase hasn't run, the OccName
-- is unlikely to be informative (like 's'),
-- so print the unique
ppr_occ_name occ = pprEncodedFS (occNameFS occ)
-- Don't use pprOccName; instead, just print the string of the OccName;
-- we print the namespace in the debug stuff above
\end{code}
%************************************************************************
......
......@@ -13,7 +13,7 @@ module Var (
TyVar, mkTyVar, mkTcTyVar,
tyVarName, tyVarKind,
setTyVarName, setTyVarUnique,
tcTyVarRef, tcTyVarDetails,
tcTyVarDetails,
-- Ids
Id, DictId,
......@@ -34,9 +34,8 @@ module Var (
#include "HsVersions.h"
import {-# SOURCE #-} TypeRep( Type )
import {-# SOURCE #-} TcType( TyVarDetails )
import {-# SOURCE #-} IdInfo( GlobalIdDetails, notGlobalId,
IdInfo, seqIdInfo )
import {-# SOURCE #-} TcType( TcTyVarDetails )
import {-# SOURCE #-} IdInfo( GlobalIdDetails, notGlobalId, IdInfo, seqIdInfo )
import Name ( Name, OccName, NamedThing(..),
setNameUnique, setNameOcc, nameUnique
......@@ -45,7 +44,6 @@ import Kind ( Kind )
import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey# )
import FastTypes
import Outputable
import DATA_IOREF
\end{code}
......@@ -71,11 +69,10 @@ data Var
tyVarKind :: Kind }
| TcTyVar { -- Used only during type inference
varName :: !Name, -- Could we get away without a Name?
varName :: !Name,
realUnique :: FastInt,
tyVarKind :: Kind,
tcTyVarRef :: IORef (Maybe Type),
tcTyVarDetails :: TyVarDetails }
tcTyVarDetails :: TcTyVarDetails }
| GlobalId { -- Used for imported Ids, dict selectors etc
varName :: !Name,
......@@ -180,12 +177,11 @@ mkTyVar name kind = TyVar { varName = name
, tyVarKind = kind
}
mkTcTyVar :: Name -> Kind -> TyVarDetails -> IORef (Maybe Type) -> TyVar
mkTcTyVar name kind details ref
mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar
mkTcTyVar name kind details
= TcTyVar { varName = name,
realUnique = getKey# (nameUnique name),
tyVarKind = kind,
tcTyVarRef = ref,
tcTyVarDetails = details
}
\end{code}
......
......@@ -7,112 +7,140 @@
module VarEnv (
VarEnv, IdEnv, TyVarEnv,
emptyVarEnv, unitVarEnv, mkVarEnv,
elemVarEnv, rngVarEnv,
elemVarEnv, varEnvElts,
extendVarEnv, extendVarEnv_C, extendVarEnvList,
plusVarEnv, plusVarEnv_C,
delVarEnvList, delVarEnv,
lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv,
mapVarEnv, zipVarEnv,
modifyVarEnv, modifyVarEnv_Directly,
isEmptyVarEnv, foldVarEnv,
isEmptyVarEnv, foldVarEnv,
lookupVarEnv_Directly,
filterVarEnv_Directly,
-- TidyEnvs
TidyEnv, emptyTidyEnv,
-- InScopeSet
InScopeSet, emptyInScopeSet, mkInScopeSet, delInScopeSet,
extendInScopeSet, extendInScopeSetList, modifyInScopeSet,
getInScopeVars, lookupInScope, elemInScopeSet, uniqAway,
-- SubstEnvs
SubstEnv, TyVarSubstEnv, SubstResult(..),
emptySubstEnv, substEnvEnv, elemSubstEnv,
mkSubstEnv, lookupSubstEnv, extendSubstEnv, extendSubstEnvList,
delSubstEnv, delSubstEnvList, noTypeSubst, isEmptySubstEnv
-- TidyEnvs
TidyEnv, emptyTidyEnv
) where
#include "HsVersions.h"
import {-# SOURCE #-} CoreSyn( CoreExpr )
import {-# SOURCE #-} TypeRep( Type )
import BasicTypes ( OccInfo )
import OccName ( TidyOccEnv, emptyTidyOccEnv )
import Var ( Var, Id )
import Var ( Var, setVarUnique )
import VarSet
import UniqFM
import Unique ( Unique, deriveUnique, getUnique )
import Util ( zipEqual )
import CmdLineOpts ( opt_PprStyle_Debug )
import Outputable
import FastTypes
\end{code}
%************************************************************************
%* *
\subsection{Tidying}
In-scope sets
%* *
%************************************************************************
When tidying up print names, we keep a mapping of in-scope occ-names
(the TidyOccEnv) and a Var-to-Var of the current renamings.
\begin{code}
type TidyEnv = (TidyOccEnv, VarEnv Var)
data InScopeSet = InScope (VarEnv Var) FastInt
-- The Int# is a kind of hash-value used by uniqAway
-- For example, it might be the size of the set
-- INVARIANT: it's not zero; we use it as a multiplier in uniqAway
instance Outputable InScopeSet where
ppr (InScope s i) = ptext SLIT("InScope") <+> ppr s
emptyInScopeSet :: InScopeSet
emptyInScopeSet = InScope emptyVarSet 1#
getInScopeVars :: InScopeSet -> VarEnv Var
getInScopeVars (InScope vs _) = vs
mkInScopeSet :: VarEnv Var -> InScopeSet
mkInScopeSet in_scope = InScope in_scope 1#
extendInScopeSet :: InScopeSet -> Var -> InScopeSet
extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# 1#)
extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
extendInScopeSetList (InScope in_scope n) vs
= InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs)
(n +# iUnbox (length vs))
modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet
-- Exploit the fact that the in-scope "set" is really a map
-- Make old_v map to new_v
modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# 1#)
delInScopeSet :: InScopeSet -> Var -> InScopeSet
delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n
elemInScopeSet :: Var -> InScopeSet -> Bool
elemInScopeSet v (InScope in_scope n) = v `elemVarEnv` in_scope
lookupInScope :: InScopeSet -> Var -> Maybe Var
-- It's important to look for a fixed point
-- When we see (case x of y { I# v -> ... })
-- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder).
-- When we lookup up an occurrence of x, we map to y, but then
-- we want to look up y in case it has acquired more evaluation information by now.
lookupInScope (InScope in_scope n) v
= go v
where
go v = case lookupVarEnv in_scope v of
Just v' | v == v' -> Just v' -- Reached a fixed point
| otherwise -> go v'
Nothing -> Nothing
\end{code}
emptyTidyEnv :: TidyEnv
emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv)
\begin{code}
uniqAway :: InScopeSet -> Var -> Var
-- (uniqAway in_scope v) finds a unique that is not used in the
-- in-scope set, and gives that to v. It starts with v's current unique, of course,
-- in the hope that it won't have to change it, and thereafter uses a combination
-- of that and the hash-code found in the in-scope set
uniqAway (InScope set n) var
| not (var `elemVarSet` set) = var -- Nothing to do
| otherwise = try 1#
where
orig_unique = getUnique var
try k
#ifdef DEBUG
| k ># 1000#
= pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
#endif
| uniq `elemVarSetByKey` set = try (k +# 1#)
#ifdef DEBUG
| opt_PprStyle_Debug && k ># 3#
= pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
setVarUnique var uniq
#endif
| otherwise = setVarUnique var uniq
where
uniq = deriveUnique orig_unique (iBox (n *# k))
\end{code}
%************************************************************************
%* *
\subsection{Substitution environments}
Tidying
%* *
%************************************************************************
\begin{code}
noTys :: SubstResult -> Bool -> Bool
noTys (DoneTy ty) no_tys = False
noTys other no_tys = no_tys
data SubstEnv = SE (VarEnv SubstResult)
Bool -- True => definitely no type substitutions in the env
noTypeSubst :: SubstEnv -> Bool
noTypeSubst (SE _ nt) = nt
substEnvEnv :: SubstEnv -> VarEnv SubstResult
substEnvEnv (SE env _) = env
type TyVarSubstEnv = SubstEnv -- of the form (DoneTy ty) *only*
data SubstResult
= DoneEx CoreExpr -- Completed term
| DoneId Id OccInfo -- Completed term variable, with occurrence info; only
-- used by the simplifier
| DoneTy Type -- Completed type
| ContEx SubstEnv CoreExpr -- A suspended substitution
emptySubstEnv :: SubstEnv
emptySubstEnv = SE emptyVarEnv True
isEmptySubstEnv :: SubstEnv -> Bool
isEmptySubstEnv (SE s _) = isEmptyVarEnv s
lookupSubstEnv :: SubstEnv -> Var -> Maybe SubstResult
lookupSubstEnv (SE s _) v = lookupVarEnv s v
elemSubstEnv :: Var -> SubstEnv -> Bool
elemSubstEnv v (SE s _) = elemVarEnv v s
extendSubstEnv :: SubstEnv -> Var -> SubstResult -> SubstEnv
extendSubstEnv (SE s nt) v r = SE (extendVarEnv s v r) (noTys r nt)
mkSubstEnv :: [Var] -> [SubstResult] -> SubstEnv
mkSubstEnv bs vs = extendSubstEnvList emptySubstEnv bs vs
extendSubstEnvList :: SubstEnv -> [Var] -> [SubstResult] -> SubstEnv
extendSubstEnvList env [] [] = env
extendSubstEnvList (SE env nt) (b:bs) (r:rs) = extendSubstEnvList (SE (extendVarEnv env b r) (noTys r nt)) bs rs
When tidying up print names, we keep a mapping of in-scope occ-names
(the TidyOccEnv) and a Var-to-Var of the current renamings.
delSubstEnv :: SubstEnv -> Var -> SubstEnv
delSubstEnv (SE s nt) v = SE (delVarEnv s v) nt
\begin{code}
type TidyEnv = (TidyOccEnv, VarEnv Var)
delSubstEnvList :: SubstEnv -> [Var] -> SubstEnv
delSubstEnvList (SE s nt) vs = SE (delVarEnvList s vs) nt
emptyTidyEnv :: TidyEnv
emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv)
\end{code}
......@@ -136,12 +164,14 @@ extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a
plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a
extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a
lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a
filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a
delVarEnvList :: VarEnv a -> [Var] -> VarEnv a
delVarEnv :: VarEnv a -> Var -> VarEnv a
plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b
modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a
rngVarEnv :: VarEnv a -> [a]
varEnvElts :: VarEnv a -> [a]
isEmptyVarEnv :: VarEnv a -> Bool
lookupVarEnv :: VarEnv a -> Var -> Maybe a
......@@ -165,10 +195,12 @@ lookupWithDefaultVarEnv = lookupWithDefaultUFM
mapVarEnv = mapUFM
mkVarEnv = listToUFM
emptyVarEnv = emptyUFM
rngVarEnv = eltsUFM
varEnvElts = eltsUFM
unitVarEnv = unitUFM
isEmptyVarEnv = isNullUFM
foldVarEnv = foldUFM
lookupVarEnv_Directly = lookupUFM_Directly
filterVarEnv_Directly = filterUFM_Directly
zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys)
lookupVarEnv_NF env id = case (lookupVarEnv env id) of { Just xx -> xx }
......
......@@ -13,7 +13,8 @@ module VarSet (
intersectVarSet, intersectsVarSet,
isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey,
minusVarSet, foldVarSet, filterVarSet,
lookupVarSet, mapVarSet, sizeVarSet, seqVarSet
lookupVarSet, mapVarSet, sizeVarSet, seqVarSet,
elemVarSetByKey
) where
#include "HsVersions.h"
......@@ -59,6 +60,7 @@ filterVarSet :: (Var -> Bool) -> VarSet -> VarSet
extendVarSet_C :: (Var->Var->Var) -> VarSet -> Var -> VarSet
delVarSetByKey :: VarSet -> Unique -> VarSet
elemVarSetByKey :: Unique -> VarSet -> Bool
emptyVarSet = emptyUniqSet
unitVarSet = unitUniqSet
......@@ -87,6 +89,7 @@ sizeVarSet = sizeUniqSet
filterVarSet = filterUniqSet
extendVarSet_C combine s x = addToUFM_C combine s x x
delVarSetByKey = delFromUFM_Directly -- Can't be bothered to add this to UniqSet
elemVarSetByKey = elemUniqSet_Directly
\end{code}
\begin{code}
......
......@@ -258,9 +258,9 @@ cgLookupPanic id
pprPanic "cgPanic"
(vcat [ppr id,
ptext SLIT("static binds for:"),
vcat [ ppr (cg_id info) | info <- rngVarEnv static_binds ],
vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ],
ptext SLIT("local binds for:"),
vcat [ ppr (cg_id info) | info <- rngVarEnv local_binds ],
vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ],
ptext SLIT("SRT label") <+> pprCLabel srt
])
\end{code}
......@@ -277,7 +277,7 @@ we don't leave any (NoVolatile, NoStable) binds around...
\begin{code}
nukeVolatileBinds :: CgBindings -> CgBindings
nukeVolatileBinds binds
= mkVarEnv (foldr keep_if_stable [] (rngVarEnv binds))
= mkVarEnv (foldr keep_if_stable [] (varEnvElts binds))
where
keep_if_stable (CgIdInfo { cg_stb = NoStableLoc }) acc = acc
keep_if_stable info acc
......@@ -443,7 +443,7 @@ nukeDeadBindings live_vars = do
let (dead_stk_slots, bs') =
dead_slots live_vars
[] []
[ (cg_id b, b) | b <- rngVarEnv binds ]
[ (cg_id b, b) | b <- varEnvElts binds ]
setBinds $ mkVarEnv bs'
freeStackSlots dead_stk_slots
\end{code}
......@@ -486,6 +486,6 @@ getLiveStackSlots :: FCode [VirtualSpOffset]
getLiveStackSlots
= do { binds <- getBinds
; return [off | CgIdInfo { cg_stb = VirStkLoc off,
cg_rep = rep } <- rngVarEnv binds,
cg_rep = rep } <- varEnvElts binds,
isFollowableArg rep] }
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgCase.lhs,v 1.70 2004/08/13 13:25:45 simonmar Exp $
% $Id: CgCase.lhs,v 1.71 2004/09/30 10:35:36 simonpj Exp $
%
%********************************************************
%* *
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgClosure.lhs,v 1.63 2004/08/13 13:05:54 simonmar Exp $
% $Id: CgClosure.lhs,v 1.64 2004/09/30 10:35:39 simonpj Exp $
%
\section[CgClosure]{Code generation for closures}
......
......@@ -45,7 +45,7 @@ import CostCentre ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack,
currentCCS )
import Constants ( mIN_INTLIKE, mAX_INTLIKE, mIN_CHARLIKE, mAX_CHARLIKE )
import TyCon ( TyCon, tyConDataCons, isEnumerationTyCon, tyConName )
import DataCon ( DataCon, dataConRepArgTys, isNullaryDataCon,
import DataCon ( DataCon, dataConRepArgTys, isNullaryRepDataCon,
isUnboxedTupleCon, dataConWorkId,
dataConName, dataConRepArity
)
......@@ -404,7 +404,7 @@ static closure, for a constructor.
cgDataCon :: DataCon -> Code
cgDataCon data_con
= do { -- Don't need any dynamic closure code for zero-arity constructors
whenC (not (isNullaryDataCon data_con))
whenC (not (isNullaryRepDataCon data_con))
(emit_info dyn_cl_info tickyEnterDynCon)
-- Dynamic-Closure first, to reduce forward references
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgExpr.lhs,v 1.59 2004/08/13 13:05:58 simonmar Exp $
% $Id: CgExpr.lhs,v 1.60 2004/09/30 10:35:43 simonpj Exp $
%
%********************************************************
%* *
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgHeapery.lhs,v 1.40 2004/08/13 13:06:00 simonmar Exp $
% $Id: CgHeapery.lhs,v 1.41 2004/09/30 10:35:45 simonpj Exp $
%
\section[CgHeapery]{Heap management functions}
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
% $Id: CgLetNoEscape.lhs,v 1.25 2004/08/13 13:06:03 simonmar Exp $
% $Id: CgLetNoEscape.lhs,v 1.26 2004/09/30 10:35:47 simonpj Exp $
%
%********************************************************
%* *
......
......@@ -389,9 +389,9 @@ emitSetCCC :: CostCentre -> Code
emitSetCCC cc
| not opt_SccProfilingOn = nopC
| otherwise = do
ASSERTM(sccAbleCostCentre cc)
tmp <- newTemp wordRep
pushCostCentre tmp curCCS cc
ASSERT( sccAbleCostCentre cc )
pushCostCentre tmp curCCS cc
stmtC (CmmStore curCCSAddr (CmmReg tmp))
when (isSccCountCostCentre cc) $
stmtC (bumpSccCount curCCS)
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgStackery.lhs,v 1.26 2004/08/17 15:23:48 simonpj Exp $
% $Id: CgStackery.lhs,v 1.27 2004/09/30 10:35:49 simonpj Exp $
%
\section[CgStackery]{Stack management functions}
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgTailCall.lhs,v 1.39 2004/08/13 13:06:13 simonmar Exp $
% $Id: CgTailCall.lhs,v 1.40 2004/09/30 10:35:50 simonpj Exp $
%
%********************************************************
%* *
......
......@@ -65,7 +65,7 @@ import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling,
opt_Parallel, opt_DoTickyProfiling,
opt_SMP )
import Id ( Id, idType, idArity, idName )
import DataCon ( DataCon, dataConTyCon, isNullaryDataCon, dataConName )
import DataCon ( DataCon, dataConTyCon, isNullaryRepDataCon, dataConName )
import Name ( Name, nameUnique, getOccName, getOccString )
import OccName ( occNameUserString )
import Type ( isUnLiftedType, Type, repType, splitTyConApp_maybe )
......@@ -663,7 +663,7 @@ staticClosureNeedsLink :: ClosureInfo -> Bool
staticClosureNeedsLink (ClosureInfo { closureSRT = srt })
= needsSRT srt
staticClosureNeedsLink (ConInfo { closureSMRep = sm_rep, closureCon = con })
= not (isNullaryDataCon con) && not_nocaf_constr
= not (isNullaryRepDataCon con) && not_nocaf_constr
where
not_nocaf_constr =
case sm_rep of
......
......@@ -53,7 +53,7 @@ import OccName ( mkLocalOcc )
import TyCon ( isDataTyCon )
import Module ( Module, mkModuleName )
import ErrUtils ( dumpIfSet_dyn, showPass )
import Panic ( assertPanic, trace )
import Panic ( assertPanic )
import qualified Module ( moduleName )
#ifdef DEBUG
......
......@@ -127,8 +127,10 @@ expr_fvs (Note _ expr) = expr_fvs expr
expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg
expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)