Commit bca9dd54 authored by simonmar's avatar simonmar

[project @ 2000-11-07 15:21:38 by simonmar]

This commit completes the merge of compiler part
	of the HEAD with the before-ghci-branch to
        before-ghci-branch-merged.
parent c8883ba0
......@@ -28,6 +28,15 @@ name = global (value) :: IORef (ty); \
#define WARN(e,msg)
#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
#if __STDC__
#define CAT2(a,b)a##b
#else
......
......@@ -47,6 +47,7 @@ module Id (
setIdArityInfo,
setIdDemandInfo,
setIdStrictness,
setIdTyGenInfo,
setIdWorkerInfo,
setIdSpecialisation,
setIdCafInfo,
......@@ -57,6 +58,7 @@ module Id (
idFlavour,
idDemandInfo,
idStrictness,
idTyGenInfo,
idWorkerInfo,
idUnfolding,
idSpecialisation,
......@@ -82,14 +84,15 @@ import Var ( Id, DictId,
)
import VarSet
import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars,
seqType, splitTyConApp_maybe )
usOnce, seqType, splitTyConApp_maybe )
import IdInfo
import Demand ( Demand )
import Name ( Name, OccName,
mkSysLocalName, mkLocalName,
isUserExportedName, getOccName, isIPOcc
isUserExportedName, nameIsLocallyDefined,
getOccName, isIPOcc
)
import OccName ( UserFS )
import PrimRep ( PrimRep )
......@@ -98,11 +101,13 @@ import FieldLabel ( FieldLabel )
import SrcLoc ( SrcLoc )
import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques,
getNumBuiltinUniques )
import Outputable
infixl 1 `setIdUnfolding`,
`setIdArityInfo`,
`setIdDemandInfo`,
`setIdStrictness`,
`setIdTyGenInfo`,
`setIdWorkerInfo`,
`setIdSpecialisation`,
`setInlinePragma`,
......@@ -272,7 +277,15 @@ in some other interface unfolding.
\begin{code}
omitIfaceSigForId :: Id -> Bool
omitIfaceSigForId id
| otherwise
= ASSERT2( not (omit && nameIsLocallyDefined (idName id)
&& idTyGenInfo id /= TyGenNever),
ppr id )
-- mustn't omit type signature for a name whose type might change!
omit
where
omit = omitIfaceSigForId' id
omitIfaceSigForId' id
= case idFlavour id of
RecordSelId _ -> True -- Includes dictionary selectors
PrimOpId _ -> True
......@@ -331,6 +344,14 @@ setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info)
isBottomingId :: Id -> Bool
isBottomingId id = isBottomingStrictness (idStrictness id)
---------------------------------
-- TYPE GENERALISATION
idTyGenInfo :: Id -> TyGenInfo
idTyGenInfo id = tyGenInfo (idInfo id)
setIdTyGenInfo :: Id -> TyGenInfo -> Id
setIdTyGenInfo id tygen_info = modifyIdInfo (`setTyGenInfo` tygen_info) id
---------------------------------
-- WORKER ID
idWorkerInfo :: Id -> WorkerInfo
......@@ -413,11 +434,14 @@ idLBVarInfo :: Id -> LBVarInfo
idLBVarInfo id = lbvarInfo (idInfo id)
isOneShotLambda :: Id -> Bool
isOneShotLambda id = case idLBVarInfo id of
IsOneShotLambda -> True
NoLBVarInfo -> case splitTyConApp_maybe (idType id) of
Just (tycon,_) -> tycon == statePrimTyCon
other -> False
isOneShotLambda id = analysis || hack
where analysis = case idLBVarInfo id of
LBVarInfo u | u == usOnce -> True
other -> False
hack = case splitTyConApp_maybe (idType id) of
Just (tycon,_) | tycon == statePrimTyCon -> True
other -> False
-- The last clause is a gross hack. It claims that
-- every function over realWorldStatePrimTy is a one-shot
-- function. This is pretty true in practice, and makes a big
......@@ -437,7 +461,7 @@ isOneShotLambda id = case idLBVarInfo id of
-- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.
setOneShotLambda :: Id -> Id
setOneShotLambda id = modifyIdInfo (`setLBVarInfo` IsOneShotLambda) id
setOneShotLambda id = modifyIdInfo (`setLBVarInfo` LBVarInfo usOnce) id
clearOneShotLambda :: Id -> Id
clearOneShotLambda id
......@@ -457,13 +481,3 @@ zapLamIdInfo :: Id -> Id
zapLamIdInfo id = maybeModifyIdInfo zapLamInfo id
\end{code}
......@@ -29,9 +29,13 @@ module IdInfo (
StrictnessInfo(..),
mkStrictnessInfo, noStrictnessInfo,
ppStrictnessInfo,isBottomingStrictness,
strictnessInfo, setStrictnessInfo,
-- Usage generalisation
TyGenInfo(..),
tyGenInfo, setTyGenInfo,
noTyGenInfo, isNoTyGenInfo, ppTyGenInfo, tyGenInfoString,
-- Worker
WorkerInfo(..), workerExists, wrapperArity, workerId,
workerInfo, setWorkerInfo, ppWorkerInfo,
......@@ -69,6 +73,7 @@ module IdInfo (
import CoreSyn
import Type ( Type, usOnce )
import PrimOp ( PrimOp )
import Var ( Id )
import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBreaker,
......@@ -78,10 +83,13 @@ import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBrea
)
import DataCon ( DataCon )
import FieldLabel ( FieldLabel )
import Type ( usOnce, usMany )
import Demand -- Lots of stuff
import Outputable
import Util ( seqList )
infixl 1 `setDemandInfo`,
`setTyGenInfo`,
`setStrictnessInfo`,
`setSpecInfo`,
`setArityInfo`,
......@@ -89,6 +97,7 @@ infixl 1 `setDemandInfo`,
`setUnfoldingInfo`,
`setCprInfo`,
`setWorkerInfo`,
`setLBVarInfo`,
`setCafInfo`,
`setOccInfo`
-- infixl so you can say (id `set` a `set` b)
......@@ -118,6 +127,7 @@ data IdInfo
arityInfo :: ArityInfo, -- Its arity
demandInfo :: Demand, -- Whether or not it is definitely demanded
specInfo :: CoreRules, -- Specialisations of this function which exist
tyGenInfo :: TyGenInfo, -- Restrictions on usage-generalisation of this Id
strictnessInfo :: StrictnessInfo, -- Strictness properties
workerInfo :: WorkerInfo, -- Pointer to Worker Function
unfoldingInfo :: Unfolding, -- Its unfolding
......@@ -137,6 +147,7 @@ megaSeqIdInfo info
seqArity (arityInfo info) `seq`
seqDemand (demandInfo info) `seq`
seqRules (specInfo info) `seq`
seqTyGenInfo (tyGenInfo info) `seq`
seqStrictnessInfo (strictnessInfo info) `seq`
seqWorker (workerInfo info) `seq`
......@@ -155,6 +166,7 @@ Setters
\begin{code}
setWorkerInfo info wk = wk `seq` info { workerInfo = wk }
setSpecInfo info sp = PSEQ sp (info { specInfo = sp })
setTyGenInfo info tg = tg `seq` info { tyGenInfo = tg }
setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr }
setOccInfo info oc = oc `seq` info { occInfo = oc }
setStrictnessInfo info st = st `seq` info { strictnessInfo = st }
......@@ -203,6 +215,7 @@ mkIdInfo flv = IdInfo {
arityInfo = UnknownArity,
demandInfo = wwLazy,
specInfo = emptyCoreRules,
tyGenInfo = noTyGenInfo,
workerInfo = NoWorker,
strictnessInfo = NoStrictnessInfo,
unfoldingInfo = noUnfolding,
......@@ -348,6 +361,83 @@ instance Show InlinePragInfo where
\end{code}
%************************************************************************
%* *
\subsection[TyGen-IdInfo]{Type generalisation info about an @Id@}
%* *
%************************************************************************
Certain passes (notably usage inference) may change the type of an
identifier, modifying all in-scope uses of that identifier
appropriately to maintain type safety.
However, some identifiers must not have their types changed in this
way, because their types are conjured up in the front end of the
compiler rather than being read from the interface file. Default
methods, dictionary functions, record selectors, and others are in
this category. (see comment at TcClassDcl.tcClassSig).
To indicate this property, such identifiers are marked TyGenNever.
Furthermore, if the usage inference generates a usage-specialised
variant of a function, we must NOT re-infer a fully-generalised type
at the next inference. This finer property is indicated by a
TyGenUInfo on the identifier.
\begin{code}
data TyGenInfo
= NoTyGenInfo -- no restriction on type generalisation
| TyGenUInfo [Maybe Type] -- restrict generalisation of this Id to
-- preserve specified usage annotations
| TyGenNever -- never generalise the type of this Id
deriving ( Eq )
\end{code}
For TyGenUInfo, the list has one entry for each usage annotation on
the type of the Id, in left-to-right pre-order (annotations come
before the type they annotate). Nothing means no restriction; Just
usOnce or Just usMany forces that annotation to that value. Other
usage annotations are illegal.
\begin{code}
seqTyGenInfo :: TyGenInfo -> ()
seqTyGenInfo NoTyGenInfo = ()
seqTyGenInfo (TyGenUInfo us) = seqList us ()
seqTyGenInfo TyGenNever = ()
noTyGenInfo :: TyGenInfo
noTyGenInfo = NoTyGenInfo
isNoTyGenInfo :: TyGenInfo -> Bool
isNoTyGenInfo NoTyGenInfo = True
isNoTyGenInfo _ = False
-- NB: There's probably no need to write this information out to the interface file.
-- Why? Simply because imported identifiers never get their types re-inferred.
-- But it's definitely nice to see in dumps, it for debugging purposes.
ppTyGenInfo :: TyGenInfo -> SDoc
ppTyGenInfo NoTyGenInfo = empty
ppTyGenInfo (TyGenUInfo us) = ptext SLIT("__G") <+> text (tyGenInfoString us)
ppTyGenInfo TyGenNever = ptext SLIT("__G N")
tyGenInfoString us = map go us
where go Nothing = 'x' -- for legibility, choose
go (Just u) | u == usOnce = '1' -- chars with identity
| u == usMany = 'M' -- Z-encoding.
go other = pprPanic "IdInfo.tyGenInfoString: unexpected annotation" (ppr other)
instance Outputable TyGenInfo where
ppr = ppTyGenInfo
instance Show TyGenInfo where
showsPrec p c = showsPrecSDoc p (ppr c)
\end{code}
%************************************************************************
%* *
\subsection[worker-IdInfo]{Worker info about an @Id@}
......@@ -495,8 +585,10 @@ work.
data LBVarInfo
= NoLBVarInfo
| IsOneShotLambda -- The lambda that binds this Id is applied
-- at most once
| LBVarInfo Type -- The lambda that binds this Id has this usage
-- annotation (i.e., if ==usOnce, then the
-- lambda is applied at most once).
-- The annotation's kind must be `$'
-- 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.
......@@ -510,9 +602,13 @@ noLBVarInfo = NoLBVarInfo
-- not safe to print or parse LBVarInfo because it is not really a
-- property of the definition, but a property of the context.
pprLBVarInfo NoLBVarInfo = empty
pprLBVarInfo IsOneShotLambda = getPprStyle $ \ sty ->
if ifaceStyle sty then empty
else ptext SLIT("OneShot")
pprLBVarInfo (LBVarInfo u) | u == usOnce
= getPprStyle $ \ sty ->
if ifaceStyle sty
then empty
else ptext SLIT("OneShot")
| otherwise
= empty
instance Outputable LBVarInfo where
ppr = pprLBVarInfo
......
......@@ -43,8 +43,7 @@ import Rules ( addRule )
import Type ( Type, ThetaType, mkDictTy, mkDictTys, mkTyConApp, mkTyVarTys,
mkFunTys, mkFunTy, mkSigmaTy,
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
splitFunTys, splitForAllTys, unUsgTy,
mkUsgTy, UsageAnn(..)
splitFunTys, splitForAllTys
)
import Module ( Module )
import CoreUtils ( exprType, mkInlineMe )
......@@ -79,9 +78,9 @@ import Id ( idType, mkId,
)
import IdInfo ( IdInfo, vanillaIdInfo, mkIdInfo,
exactArity, setUnfoldingInfo, setCafInfo, setCprInfo,
setArityInfo, setSpecInfo,
setArityInfo, setSpecInfo, setTyGenInfo,
mkStrictnessInfo, setStrictnessInfo,
IdFlavour(..), CafInfo(..), CprInfo(..)
IdFlavour(..), CafInfo(..), CprInfo(..), TyGenInfo(..)
)
import FieldLabel ( mkFieldLabel, fieldLabelName,
firstFieldLabelTag, allFieldLabelTags, fieldLabelType
......@@ -143,7 +142,11 @@ mkSpecPragmaId occ uniq ty loc
-- Maybe a SysLocal? But then we'd lose the location
mkDefaultMethodId dm_name rec_c ty
= mkVanillaId dm_name ty
= mkId dm_name ty info
where
info = vanillaIdInfo `setTyGenInfo` TyGenNever
-- type is wired-in (see comment at TcClassDcl.tcClassSig), so
-- do not generalise it
mkWorkerId uniq unwrkr ty
= mkVanillaId (mkDerivedName mkWorkerOcc (getName unwrkr) uniq) ty
......@@ -243,6 +246,9 @@ mkDataConWrapId data_con
-- The wrapper Id ends up in STG code as an argument,
-- sometimes before its definition, so we want to
-- signal that it has no CAFs
`setTyGenInfo` TyGenNever
-- No point generalising its type, since it gets eagerly inlined
-- away anyway
wrap_ty = mkForAllTys all_tyvars $
mkFunTys all_arg_tys
......@@ -413,6 +419,7 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
`setArityInfo` exactArity (1 + length dict_tys)
`setUnfoldingInfo` unfolding
`setCafInfo` NoCafRefs
`setTyGenInfo` TyGenNever
-- ToDo: consider adding further IdInfo
unfolding = mkTopUnfolding sel_rhs
......@@ -428,7 +435,7 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
mkLams dict_ids $ Lam data_id $
sel_body
sel_body | isNewTyCon tycon = Note (Coerce (unUsgTy field_tau) (unUsgTy data_ty)) (Var data_id)
sel_body | isNewTyCon tycon = Note (Coerce field_tau data_ty) (Var data_id)
| otherwise = Case (Var data_id) data_id (the_alts ++ default_alt)
mk_maybe_alt data_con
......@@ -446,8 +453,7 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
field_lbls = dataConFieldLabels data_con
error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy field_tau), err_string]
-- preserves invariant that type args are *not* usage-annotated on top. KSW 1999-04.
error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type field_tau, err_string]
err_string
| all safeChar full_msg
= App (Var unpack_id) (Lit (MachStr (_PK_ full_msg)))
......@@ -524,6 +530,7 @@ mkDictSelId name clas
`setArityInfo` exactArity 1
`setUnfoldingInfo` unfolding
`setCafInfo` NoCafRefs
`setTyGenInfo` TyGenNever
-- We no longer use 'must-inline' on record selectors. They'll
-- inline like crazy if they scrutinise a constructor
......@@ -622,9 +629,12 @@ mkDictFunId :: Name -- Name to use for the dict fun;
-> Id
mkDictFunId dfun_name clas inst_tyvars inst_tys dfun_theta
= mkVanillaId dfun_name dfun_ty
= mkId dfun_name dfun_ty info
where
dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
info = vanillaIdInfo `setTyGenInfo` TyGenNever
-- type is wired-in (see comment at TcClassDcl.tcClassSig), so
-- do not generalise it
{- 1 dec 99: disable the Mark Jones optimisation for the sake
of compatibility with Hugs.
......@@ -810,9 +820,8 @@ openAlphaTy = mkTyVarTy openAlphaTyVar
openBetaTy = mkTyVarTy openBetaTyVar
errorTy :: Type
errorTy = mkUsgTy UsMany $
mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkUsgTy UsOnce (mkListTy charTy)]
(mkUsgTy UsMany openAlphaTy))
errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy]
openAlphaTy)
-- Notice the openAlphaTyVar. It says that "error" can be applied
-- to unboxed as well as boxed types. This is OK because it never
-- returns, so the return type is irrelevant.
......
......@@ -8,7 +8,7 @@
module OccName (
-- The NameSpace type; abstact
NameSpace, tcName, clsName, tcClsName, dataName, varName, ipName,
tvName, uvName, nameSpaceString,
tvName, nameSpaceString,
-- The OccName type
OccName, -- Abstract, instance of Outputable
......@@ -20,7 +20,7 @@ module OccName (
mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
mkGenOcc1, mkGenOcc2,
isSysOcc, isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc, isValOcc,
isSysOcc, isTvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc, isValOcc,
occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour,
setOccNameSpace,
......@@ -86,7 +86,6 @@ data NameSpace = VarName -- Variables
| IPName -- Implicit Parameters
| DataName -- Data constructors
| TvName -- Type variables
| UvName -- Usage variables
| TcClsName -- Type constructors and classes; Haskell has them
-- in the same name space for now.
deriving( Eq, Ord )
......@@ -99,7 +98,6 @@ tcClsName = TcClsName -- Not sure which!
dataName = DataName
tvName = TvName
uvName = UvName
varName = VarName
ipName = IPName
......@@ -109,7 +107,6 @@ nameSpaceString DataName = "Data constructor"
nameSpaceString VarName = "Variable"
nameSpaceString IPName = "Implicit Param"
nameSpaceString TvName = "Type variable"
nameSpaceString UvName = "Usage variable"
nameSpaceString TcClsName = "Type constructor or class"
\end{code}
......@@ -177,7 +174,7 @@ mkCCallOcc :: EncodedString -> OccName
-- But then alreadyEncoded complains about the braces!
mkCCallOcc str = OccName varName (_PK_ str)
-- Kind constructors get a speical function. Uniquely, they are not encoded,
-- Kind constructors get a special function. Uniquely, they are not encoded,
-- so that they have names like '*'. This means that *even in interface files*
-- we'll get kinds like (* -> (* -> *)). We can't use mkSysOcc because it
-- has an ASSERT that doesn't hold.
......@@ -225,14 +222,11 @@ occNameFlavour (OccName sp _) = nameSpaceString sp
\end{code}
\begin{code}
isTvOcc, isDataSymOcc, isSymOcc, isUvOcc :: OccName -> Bool
isTvOcc, isDataSymOcc, isSymOcc :: OccName -> Bool
isTvOcc (OccName TvName _) = True
isTvOcc other = False
isUvOcc (OccName UvName _) = True
isUvOcc other = False
isValOcc (OccName VarName _) = True
isValOcc (OccName DataName _) = True
isValOcc other = False
......
......@@ -6,6 +6,5 @@ _declarations_
-- Used by Name
1 type Id = Var ;
1 type TyVar = Var ;
1 type UVar = Var ;
1 data Var ;
1 setIdName _:_ Id -> Name.Name -> Id ;;
......@@ -3,7 +3,6 @@ __export Var Var TyVar Id setIdName ;
-- Used by Name
1 type Id = Var;
1 type TyVar = Var;
1 type UVar = Var;
1 data Var ;
1 setIdName :: Id -> Name.Name -> Id ;
......@@ -17,11 +17,6 @@ module Var (
newMutTyVar, newSigTyVar,
readMutTyVar, writeMutTyVar, isMutTyVar, makeTyVarImmutable,
-- UVars
UVar,
isUVar,
mkUVar, mkNamedUVar,
-- Ids
Id, DictId,
idName, idType, idUnique, idInfo, modifyIdInfo, maybeModifyIdInfo,
......@@ -76,7 +71,6 @@ data VarDetails
| MutTyVar (IORef (Maybe Type)) -- Used during unification;
Bool -- True <=> this is a type signature variable, which
-- should not be unified with a non-tyvar type
| UVar -- Usage variable
-- For a long time I tried to keep mutable Vars statically type-distinct
-- from immutable Vars, but I've finally given up. It's just too painful.
......@@ -212,43 +206,6 @@ isSigTyVar other = False
\end{code}
%************************************************************************
%* *
\subsection{Usage variables}
%* *
%************************************************************************
\begin{code}
type UVar = Var
\end{code}
\begin{code}
mkUVar :: Unique -> UVar
mkUVar unique = Var { varName = name
, realUnique = getKey unique
, varDetails = UVar
, varType = pprPanic "mkUVar (varType)" (ppr name)
, varInfo = pprPanic "mkUVar (varInfo)" (ppr name)
}
where name = mkSysLocalName unique SLIT("u")
mkNamedUVar :: Name -> UVar
mkNamedUVar name = Var { varName = name
, realUnique = getKey (nameUnique name)
, varDetails = UVar
, varType = pprPanic "mkNamedUVar (varType)" (ppr name)
, varInfo = pprPanic "mkNamedUVar (varInfo)" (ppr name)
}
\end{code}
\begin{code}
isUVar :: Var -> Bool
isUVar (Var {varDetails = details}) = case details of
UVar -> True
other -> False
\end{code}
%************************************************************************
%* *
\subsection{Id Construction}
......
......@@ -5,7 +5,7 @@
\begin{code}
module VarSet (
VarSet, IdSet, TyVarSet, UVarSet,
VarSet, IdSet, TyVarSet,
emptyVarSet, unitVarSet, mkVarSet,
extendVarSet, extendVarSet_C,
elemVarSet, varSetElems, subVarSet,
......@@ -18,7 +18,7 @@ module VarSet (
#include "HsVersions.h"
import Var ( Var, Id, TyVar, UVar )
import Var ( Var, Id, TyVar )
import Unique ( Unique )
import UniqSet
import UniqFM ( delFromUFM_Directly, addToUFM_C )
......@@ -34,7 +34,6 @@ import UniqFM ( delFromUFM_Directly, addToUFM_C )
type VarSet = UniqSet Var
type IdSet = UniqSet Id
type TyVarSet = UniqSet TyVar
type UVarSet = UniqSet UVar
emptyVarSet :: VarSet
intersectVarSet :: VarSet -> VarSet -> VarSet
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgCase.lhs,v 1.47 2000/11/07 13:12:22 simonpj Exp $
% $Id: CgCase.lhs,v 1.48 2000/11/07 15:21:39 simonmar Exp $
%
%********************************************************
%* *
......@@ -874,7 +874,7 @@ restoreCurrentCostCentre (Just slot)
freeStackSlots [slot] `thenC`
returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
-- we use the RESTORE_CCCS macro, rather than just
-- assigning into CurCostCentre, in case RESTORE_CCC
-- assigning into CurCostCentre, in case RESTORE_CCCS
-- has some sanity-checking in it.
\end{code}
......
......@@ -49,7 +49,7 @@ module CoreSyn (
import CostCentre ( CostCentre, noCostCentre )
import Var ( Var, Id, TyVar, isTyVar, isId )
import Type ( Type, UsageAnn, mkTyVarTy, seqType )
import Type ( Type, mkTyVarTy, seqType )
import Literal ( Literal, mkMachInt )
import DataCon ( DataCon, dataConId )
import VarSet
......@@ -103,9 +103,6 @@ data Note
| InlineMe -- Instructs simplifer to treat the enclosed expression
-- as very small, and inline it at its call sites
| TermUsg -- A term-level usage annotation
UsageAnn -- (should not be a variable except during UsageSP inference)
\end{code}
......
......@@ -55,9 +55,9 @@ import IdInfo ( LBVarInfo(..),
megaSeqIdInfo )
import Demand ( appIsBottom )
import Type ( Type, mkFunTy, mkForAllTy,
splitFunTy_maybe,
isNotUsgTy, mkUsgTy, unUsgTy, UsageAnn(..),
applyTys, isUnLiftedType, seqType
splitFunTy_maybe, tyVarsOfType, tyVarsOfTypes,
applyTys, isUnLiftedType, seqType,
mkUTy
)
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
import CostCentre ( CostCentre )
......@@ -81,7 +81,6 @@ exprType (Lit lit) = literalType lit
exprType (Let _ body) = exprType body
exprType (Case _ _ alts) = coreAltsType alts
exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
exprType (Note (TermUsg u) e) = mkUsgTy u (unUsgTy (exprType e))
exprType (Note other_note e) = exprType e
exprType (Lam binder expr) = mkPiType binder (exprType expr)
exprType e@(App _ _)
......@@ -102,8 +101,8 @@ case of a term variable.
\begin{code}
mkPiType :: Var -> Type -> Type -- The more polymorphic version doesn't work...
mkPiType v ty | isId v = (case idLBVarInfo v of
IsOneShotLambda -> mkUsgTy UsOnce
otherwise -> id) $