Skip to content

GitLab

Commit 2c8f04b5 authored by simonpj's avatar simonpj
Browse files

[project @ 1998-03-19 23:54:49 by simonpj] 

Reorganisation of Id, IdInfo.  Remove StdIdInfo, PragmaInfo; add basicTypes/MkId.lhs
parent 350263b7
Expand all Hide whitespace changes
Inline Side-by-side
ghc/compiler/absCSyn/CLabel.lhs
View file @ 2c8f04b5
......@@ -55,16 +55,15 @@ import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl )
import CgRetConv ( CtrlReturnConvention(..), ctrlReturnConvAlg )
import CStrings ( pp_cSEP )
import Id ( externallyVisibleId,
isDataCon, isDictFunId,
isDefaultMethodId_maybe,
isDataCon,
fIRST_TAG,
ConTag,
Id
)
import Maybes ( maybeToBool )
import PprType ( showTyCon, GenType{-instance Outputable-} )
import TyCon ( TyCon{-instance Eq-} )
import Unique ( showUnique, pprUnique, Unique{-instance Eq-} )
import PprType ( showTyCon )
import TyCon ( TyCon )
import Unique ( showUnique, pprUnique, Unique )
import Util ( assertPanic{-, pprTraceToDo:rm-} )
import Outputable
\end{code}
......
ghc/compiler/basicTypes/FieldLabel.lhs
View file @ 2c8f04b5
......@@ -24,6 +24,8 @@ data FieldLabel
-- The type in the FieldLabel for op1 will be simply (a->a).
FieldLabelTag -- Indicates position within constructor
-- (starting with firstFieldLabelTag)
--
-- If the same field occurs in more than one constructor
-- then it'll have a separate FieldLabel on each occasion,
-- but with a single name (and presumably the same type!)
......@@ -36,7 +38,7 @@ firstFieldLabelTag :: FieldLabelTag
firstFieldLabelTag = 1
allFieldLabelTags :: [FieldLabelTag]
allFieldLabelTags = [1..]
allFieldLabelTags = [firstFieldLabelTag..]
fieldLabelName (FieldLabel n _ _) = n
fieldLabelType (FieldLabel _ ty _) = ty
......
ghc/compiler/basicTypes/Id.hi-boot
View file @ 2c8f04b5
_interface_ Id 1
_exports_
Id Id GenId StrictnessMark(MarkedStrict NotMarkedStrict) dataConArgTys idType isNullaryDataCon mkDataCon mkTupleCon pprId idName;
Id Id GenId StrictnessMark(MarkedStrict NotMarkedStrict) idType isNullaryDataCon mkDataCon mkTupleCon pprId idName;
_declarations_
1 type Id = Id.GenId Type!Type ;
1 data GenId ty ;
1 data StrictnessMark = MarkedStrict | NotMarkedStrict ;
-- Not needed any more by Type.lhs
-- 1 dataConArgTys _:_ Id -> [Type!Type] -> [Type!Type] ;;
1 idType _:_ Id.Id -> Type!Type ;;
1 isNullaryDataCon _:_ Id -> PrelBase.Bool ;;
1 mkDataCon _:_ Name.Name -> [Id.StrictnessMark] -> [FieldLabel!FieldLabel] -> [TyVar.TyVar] -> Type.ThetaType -> [TyVar.TyVar] -> Type!ThetaType -> [Type!TauType] -> TyCon!TyCon -> Id ;;
......
ghc/compiler/basicTypes/Id.lhs
View file @ 2c8f04b5
This diff is collapsed.
ghc/compiler/basicTypes/IdInfo.lhs
View file @ 2c8f04b5
......@@ -13,32 +13,43 @@ module IdInfo (
noIdInfo,
ppIdInfo,
-- Arity
ArityInfo(..),
exactArity, atLeastArity, unknownArity,
arityInfo, addArityInfo, ppArityInfo,
arityInfo, setArityInfo, ppArityInfo,
-- Demand
DemandInfo,
noDemandInfo, mkDemandInfo, demandInfo, ppDemandInfo, addDemandInfo, willBeDemanded,
noDemandInfo, mkDemandInfo, demandInfo, ppDemandInfo, setDemandInfo, willBeDemanded,
Demand(..), -- Non-abstract
-- Strictness
StrictnessInfo(..), -- Non-abstract
Demand(..), NewOrData, -- Non-abstract
workerExists,
mkStrictnessInfo, mkBottomStrictnessInfo, noStrictnessInfo, bottomIsGuaranteed,
strictnessInfo, ppStrictnessInfo, addStrictnessInfo,
strictnessInfo, ppStrictnessInfo, setStrictnessInfo,
-- Unfolding
unfoldingInfo, setUnfoldingInfo,
unfoldInfo, addUnfoldInfo,
-- Inline prags
InlinePragInfo(..),
inlinePragInfo, setInlinePragInfo,
-- Specialisation
IdSpecEnv, specInfo, setSpecInfo,
-- Update
UpdateInfo, UpdateSpec,
mkUpdateInfo, updateInfo, updateInfoMaybe, ppUpdateInfo, addUpdateInfo,
mkUpdateInfo, updateInfo, updateInfoMaybe, ppUpdateInfo, setUpdateInfo,
-- Arg usage
ArgUsageInfo, ArgUsage(..), ArgUsageType,
mkArgUsageInfo, argUsageInfo, addArgUsageInfo, getArgUsage,
mkArgUsageInfo, argUsageInfo, setArgUsageInfo, getArgUsage,
-- FB type
FBTypeInfo, FBType(..), FBConsum(..), FBProd(..),
fbTypeInfo, ppFBTypeInfo, addFBTypeInfo, mkFBTypeInfo, getFBType
fbTypeInfo, ppFBTypeInfo, setFBTypeInfo, mkFBTypeInfo, getFBType
) where
#include "HsVersions.h"
......@@ -73,29 +84,55 @@ The @IdInfo@ gives information about the value, or definition, of the
\begin{code}
data IdInfo
= IdInfo
ArityInfo -- Its arity
= IdInfo {
arityInfo :: ArityInfo, -- Its arity
demandInfo :: DemandInfo, -- Whether or not it is definitely demanded
specInfo :: IdSpecEnv, -- Specialisations of this function which exist
strictnessInfo :: StrictnessInfo, -- Strictness properties
DemandInfo -- Whether or not it is definitely
-- demanded
unfoldingInfo :: Unfolding, -- Its unfolding; for locally-defined
-- things, this can *only* be NoUnfolding
IdSpecEnv -- Specialisations of this function which exist
updateInfo :: UpdateInfo, -- Which args should be updated
StrictnessInfo -- Strictness properties
argUsageInfo :: ArgUsageInfo, -- how this Id uses its arguments
Unfolding -- Its unfolding; for locally-defined
-- things, this can *only* be NoUnfolding
fbTypeInfo :: FBTypeInfo, -- the Foldr/Build W/W property of this function.
UpdateInfo -- Which args should be updated
inlinePragInfo :: InlinePragInfo -- Inline pragmas
}
\end{code}
ArgUsageInfo -- how this Id uses its arguments
Setters
FBTypeInfo -- the Foldr/Build W/W property of this function.
\begin{code}
setFBTypeInfo fb info = info { fbTypeInfo = fb }
setArgUsageInfo au info = info { argUsageInfo = au }
setUpdateInfo ud info = info { updateInfo = ud }
setDemandInfo dd info = info { demandInfo = dd }
setStrictnessInfo st info = info { strictnessInfo = st }
setSpecInfo sp info = info { specInfo = sp }
setArityInfo ar info = info { arityInfo = ar }
setInlinePragInfo pr info = info { inlinePragInfo = pr }
setUnfoldingInfo uf info = info { unfoldingInfo = uf }
\end{code}
\begin{code}
noIdInfo = IdInfo UnknownArity UnknownDemand emptySpecEnv NoStrictnessInfo noUnfolding
NoUpdateInfo NoArgUsageInfo NoFBTypeInfo
noIdInfo = IdInfo {
arityInfo = UnknownArity,
demandInfo = UnknownDemand,
specInfo = emptySpecEnv,
strictnessInfo = NoStrictnessInfo,
unfoldingInfo = noUnfolding,
updateInfo = NoUpdateInfo,
argUsageInfo = NoArgUsageInfo,
fbTypeInfo = NoFBTypeInfo,
inlinePragInfo = NoPragmaInfo
}
\end{code}
\begin{code}
......@@ -103,23 +140,12 @@ ppIdInfo :: Bool -- True <=> print specialisations, please
-> IdInfo
-> SDoc
ppIdInfo specs_please
(IdInfo arity demand specenv strictness unfold update arg_usage fbtype)
ppIdInfo specs_please (IdInfo {arityInfo, updateInfo, strictnessInfo, demandInfo})
= hsep [
-- order is important!:
ppArityInfo arity,
ppUpdateInfo update,
ppStrictnessInfo strictness,
if specs_please
then empty -- ToDo -- sty (not (isDataCon for_this_id))
-- better_id_fn inline_env (mEnvToList specenv)
else empty,
-- DemandInfo needn't be printed since it has no effect on interfaces
ppDemandInfo demand,
ppFBTypeInfo fbtype
ppArityInfo arityInfo,
ppUpdateInfo updateInfo,
ppStrictnessInfo strictnessInfo,
ppDemandInfo demandInfo
]
\end{code}
......@@ -134,60 +160,34 @@ data ArityInfo
= UnknownArity -- No idea
| ArityExactly Int -- Arity is exactly this
| ArityAtLeast Int -- Arity is this or greater
\end{code}
\begin{code}
exactArity = ArityExactly
atLeastArity = ArityAtLeast
unknownArity = UnknownArity
arityInfo (IdInfo arity _ _ _ _ _ _ _) = arity
addArityInfo (IdInfo _ a b c d e f g) arity = IdInfo arity a b c d e f g
ppArityInfo UnknownArity = empty
ppArityInfo UnknownArity = empty
ppArityInfo (ArityExactly arity) = hsep [ptext SLIT("_A_"), int arity]
ppArityInfo (ArityAtLeast arity) = hsep [ptext SLIT("_A>_"), int arity]
\end{code}
%************************************************************************
%* *
\subsection[demand-IdInfo]{Demand info about an @Id@}
\subsection{Inline-pragma information}
%* *
%************************************************************************
Whether a value is certain to be demanded or not. (This is the
information that is computed by the ``front-end'' of the strictness
analyser.)
This information is only used within a module, it is not exported
(obviously).
\begin{code}
data DemandInfo
= UnknownDemand
| DemandedAsPer Demand
\end{code}
data InlinePragInfo
= NoPragmaInfo
\begin{code}
noDemandInfo = UnknownDemand
| IWantToBeINLINEd
mkDemandInfo :: Demand -> DemandInfo
mkDemandInfo demand = DemandedAsPer demand
| IMustNotBeINLINEd -- Used by the simplifier to prevent looping
-- on recursive definitions
willBeDemanded :: DemandInfo -> Bool
willBeDemanded (DemandedAsPer demand) = isStrict demand
willBeDemanded _ = False
| IMustBeINLINEd -- Absolutely must inline; used for PrimOps only
\end{code}
\begin{code}
demandInfo (IdInfo _ demand _ _ _ _ _ _) = demand
addDemandInfo (IdInfo a _ c d e f g h) demand = IdInfo a demand c d e f g h
ppDemandInfo UnknownDemand = text "{-# L #-}"
ppDemandInfo (DemandedAsPer info) = hsep [text "{-#", text (showList [info] ""), text "#-}"]
\end{code}
%************************************************************************
%* *
......@@ -227,13 +227,6 @@ might have a specialisation
where pi' :: Lift Int# is the specialised version of pi.
\begin{code}
specInfo :: IdInfo -> IdSpecEnv
specInfo (IdInfo _ _ spec _ _ _ _ _) = spec
setSpecInfo (IdInfo a b _ d e f g h) spec = IdInfo a b spec d e f g h
\end{code}
%************************************************************************
%* *
......@@ -292,11 +285,6 @@ mkBottomStrictnessInfo = BottomGuaranteed
bottomIsGuaranteed BottomGuaranteed = True
bottomIsGuaranteed other = False
strictnessInfo (IdInfo _ _ _ strict _ _ _ _) = strict
addStrictnessInfo id_info NoStrictnessInfo = id_info
addStrictnessInfo (IdInfo a b d _ e f g h) strict = IdInfo a b d strict e f g h
ppStrictnessInfo NoStrictnessInfo = empty
ppStrictnessInfo BottomGuaranteed = ptext SLIT("_bot_")
......@@ -314,16 +302,38 @@ workerExists other = False
%************************************************************************
%* *
\subsection[unfolding-IdInfo]{Unfolding info about an @Id@}
\subsection[demand-IdInfo]{Demand info about an @Id@}
%* *
%************************************************************************
Whether a value is certain to be demanded or not. (This is the
information that is computed by the ``front-end'' of the strictness
analyser.)
This information is only used within a module, it is not exported
(obviously).
\begin{code}
data DemandInfo
= UnknownDemand
| DemandedAsPer Demand
\end{code}
\begin{code}
unfoldInfo (IdInfo _ _ _ _ unfolding _ _ _) = unfolding
noDemandInfo = UnknownDemand
mkDemandInfo :: Demand -> DemandInfo
mkDemandInfo demand = DemandedAsPer demand
willBeDemanded :: DemandInfo -> Bool
willBeDemanded (DemandedAsPer demand) = isStrict demand
willBeDemanded _ = False
addUnfoldInfo (IdInfo a b d e _ f g h) uf = IdInfo a b d e uf f g h
ppDemandInfo UnknownDemand = text "{-# L #-}"
ppDemandInfo (DemandedAsPer info) = hsep [text "{-#", text (showList [info] ""), text "#-}"]
\end{code}
%************************************************************************
%* *
\subsection[update-IdInfo]{Update-analysis info about an @Id@}
......@@ -352,18 +362,6 @@ updateInfoMaybe (SomeUpdateInfo u) = Just u
Text instance so that the update annotations can be read in.
\begin{code}
instance Read UpdateInfo where
readsPrec p s | null s = panic "IdInfo: empty update pragma?!"
| otherwise = [(SomeUpdateInfo (map ok_digit s),"")]
where
ok_digit c | c >= '0' && c <= '2' = ord c - ord '0'
| otherwise = panic "IdInfo: not a digit while reading update pragma"
updateInfo (IdInfo _ _ _ _ _ update _ _) = update
addUpdateInfo id_info NoUpdateInfo = id_info
addUpdateInfo (IdInfo a b d e f _ g h) upd_info = IdInfo a b d e f upd_info g h
ppUpdateInfo NoUpdateInfo = empty
ppUpdateInfo (SomeUpdateInfo []) = empty
ppUpdateInfo (SomeUpdateInfo spec) = (<>) (ptext SLIT("_U_ ")) (hcat (map int spec))
......@@ -379,10 +377,10 @@ ppUpdateInfo (SomeUpdateInfo spec) = (<>) (ptext SLIT("_U_ ")) (hcat (map int sp
data ArgUsageInfo
= NoArgUsageInfo
| SomeArgUsageInfo ArgUsageType
-- ??? deriving (Eq, Ord)
data ArgUsage = ArgUsage Int -- number of arguments (is linear!)
| UnknownArgUsage
type ArgUsageType = [ArgUsage] -- c_1 -> ... -> BLOB
\end{code}
......@@ -396,11 +394,6 @@ getArgUsage (SomeArgUsageInfo u) = u
\end{code}
\begin{code}
argUsageInfo (IdInfo _ _ _ _ _ _ au _) = au
addArgUsageInfo id_info NoArgUsageInfo = id_info
addArgUsageInfo (IdInfo a b d e f g _ h) au_info = IdInfo a b d e f g au_info h
{- UNUSED:
ppArgUsageInfo NoArgUsageInfo = empty
ppArgUsageInfo (SomeArgUsageInfo aut) = (<>) (ptext SLIT("_L_ ")) (ppArgUsageType aut)
......@@ -415,6 +408,7 @@ ppArgUsageType aut = hcat
char '"' ]
\end{code}
%************************************************************************
%* *
\subsection[FBType-IdInfo]{Type of an expression through Foldr/build's eyes}
......@@ -441,11 +435,6 @@ getFBType (SomeFBTypeInfo u) = Just u
\end{code}
\begin{code}
fbTypeInfo (IdInfo _ _ _ _ _ _ _ fb) = fb
addFBTypeInfo id_info NoFBTypeInfo = id_info
addFBTypeInfo (IdInfo a b d e f g h _) fb_info = IdInfo a b d e f g h fb_info
ppFBTypeInfo NoFBTypeInfo = empty
ppFBTypeInfo (SomeFBTypeInfo (FBType cons prod))
= (<>) (ptext SLIT("_F_ ")) (ppFBType cons prod)
......
ghc/compiler/basicTypes/IdUtils.lhs
View file @ 2c8f04b5
......@@ -10,9 +10,8 @@ module IdUtils ( primOpName ) where
import CoreSyn
import CoreUnfold ( Unfolding )
import Id ( mkPrimitiveId )
import MkId ( mkPrimitiveId )
import IdInfo -- quite a few things
import StdIdInfo
import Name ( mkWiredInIdName, Name )
import PrimOp ( primOpInfo, tagOf_PrimOp, PrimOpInfo(..), PrimOp )
import PrelMods ( pREL_GHC )
......
ghc/compiler/basicTypes/Unique.lhs
View file @ 2c8f04b5
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Unique]{The @Unique@ data type}
@Uniques@ are used to distinguish entities in the compiler (@Ids@,
@Classes@, etc.) from each other. Thus, @Uniques@ are the basic
......@@ -57,6 +54,7 @@ module Unique (
charDataConKey,
charPrimTyConKey,
charTyConKey,
coerceIdKey,
composeIdKey,
consDataConKey,
doubleDataConKey,
......@@ -92,6 +90,7 @@ module Unique (
functorClassKey,
geClassOpKey,
gtDataConKey,
inlineIdKey,
intDataConKey,
intPrimTyConKey,
intTyConKey,
......@@ -139,6 +138,7 @@ module Unique (
realWorldPrimIdKey,
realWorldTyConKey,
recConErrorIdKey,
recSelErrIdKey,
recUpdErrorIdKey,
return2GMPsDataConKey,
return2GMPsTyConKey,
......@@ -638,6 +638,7 @@ errorIdKey = mkPreludeMiscIdUnique 7
foldlIdKey = mkPreludeMiscIdUnique 8
foldrIdKey = mkPreludeMiscIdUnique 9
forkIdKey = mkPreludeMiscIdUnique 10
recSelErrIdKey = mkPreludeMiscIdUnique 11
integerMinusOneIdKey = mkPreludeMiscIdUnique 12
integerPlusOneIdKey = mkPreludeMiscIdUnique 13
integerPlusTwoIdKey = mkPreludeMiscIdUnique 14
......@@ -703,3 +704,8 @@ returnMClassOpKey = mkPreludeMiscIdUnique 66
otherwiseIdKey = mkPreludeMiscIdUnique 67
toEnumClassOpKey = mkPreludeMiscIdUnique 68
\end{code}
\begin{code}
inlineIdKey = mkPreludeMiscIdUnique 69
coerceIdKey = mkPreludeMiscIdUnique 70
\end{code}
ghc/compiler/codeGen/CgBindery.lhs
View file @ 2c8f04b5
......@@ -35,7 +35,7 @@ import ClosureInfo ( mkLFImported, mkConLFInfo, mkLFArgument, LambdaFormInfo )
import HeapOffs ( VirtualHeapOffset,
VirtualSpAOffset, VirtualSpBOffset
)
import Id ( idPrimRep, toplevelishId,
import Id ( idPrimRep,
mkIdEnv, rngIdEnv, IdEnv,
idSetToList,
Id
......@@ -231,8 +231,8 @@ getCAddrMode name
\begin{code}
getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode)
getCAddrModeIfVolatile name
| toplevelishId name = returnFC Nothing
| otherwise
-- | toplevelishId name = returnFC Nothing
-- | otherwise
= lookupBindC name `thenFC` \ ~(MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
case stable_loc of
NoStableLoc -> -- Aha! So it is volatile!
......
ghc/compiler/codeGen/CgCase.lhs
View file @ 2c8f04b5
......@@ -46,14 +46,12 @@ import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon )
import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
import CostCentre ( useCurrentCostCentre, CostCentre )
import HeapOffs ( VirtualSpBOffset, VirtualHeapOffset )
import Id ( idPrimRep, toplevelishId,
dataConTag, fIRST_TAG, ConTag,
import Id ( idPrimRep, dataConTag, fIRST_TAG, ConTag,
isDataCon, DataCon,
idSetToList, GenId{-instance Uniquable,Eq-}, Id
)
import Literal ( Literal )
import Maybes ( catMaybes )
import PprType ( GenType{-instance Outputable-} )
import PrimOp ( primOpCanTriggerGC, PrimOp(..),
primOpStackRequired, StackRequirement(..)
)
......@@ -142,46 +140,6 @@ cgCase :: StgExpr
Several special cases for primitive operations.
******* TO DO TO DO: fix what follows
Special case for
case (op x1 ... xn) of
y -> e
where the type of the case scrutinee is a multi-constuctor algebraic type.
Then we simply compile code for
let y = op x1 ... xn
in
e
In this case:
case (op x1 ... xn) of
C a b -> ...
y -> e
where the type of the case scrutinee is a multi-constuctor algebraic type.
we just bomb out at the moment. It never happens in practice.
**** END OF TO DO TO DO
\begin{code}
cgCase scrut@(StgPrim op args _) live_in_whole_case live_in_alts uniq
(StgAlgAlts _ alts (StgBindDefault id _ deflt_rhs))
= if not (null alts) then
panic "cgCase: case on PrimOp with default *and* alts\n"
-- For now, die if alts are non-empty
else
cgExpr (StgLet (StgNonRec id scrut_rhs) deflt_rhs)
where
scrut_rhs = StgRhsClosure useCurrentCostCentre stgArgOcc{-safe-} scrut_free_vars
Updatable [] scrut
scrut_free_vars = [ fv | StgVarArg fv <- args, not (toplevelishId fv) ]
-- Hack, hack
\end{code}
\begin{code}
cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts
......
ghc/compiler/coreSyn/AnnCoreSyn.lhs
View file @ 2c8f04b5
......@@ -57,11 +57,7 @@ data AnnCoreExpr' val_bdr val_occ flexi annot
| AnnLet (AnnCoreBinding val_bdr val_occ flexi annot)
(AnnCoreExpr val_bdr val_occ flexi annot)
| AnnSCC CostCentre
(AnnCoreExpr val_bdr val_occ flexi annot)
| AnnCoerce Coercion
(GenType flexi)
| AnnNote (CoreNote flexi)
(AnnCoreExpr val_bdr val_occ flexi annot)
\end{code}
......@@ -91,8 +87,7 @@ deAnnotate (_, AnnCon con args) = Con con args
deAnnotate (_, AnnPrim op args) = Prim op args
deAnnotate (_, AnnLam binder body)= Lam binder (deAnnotate body)
deAnnotate (_, AnnApp fun arg) = App (deAnnotate fun) arg
deAnnotate (_, AnnSCC lbl body) = SCC lbl (deAnnotate body)
deAnnotate (_, AnnCoerce c ty body) = Coerce c ty (deAnnotate body)
deAnnotate (_, AnnNote note body) = Note note (deAnnotate body)
deAnnotate (_, AnnLet bind body)
= Let (deAnnBind bind) (deAnnotate body)
......
ghc/compiler/coreSyn/CoreLift.lhs
View file @ 2c8f04b5
......@@ -18,10 +18,10 @@ module CoreLift (
import CoreSyn
import CoreUtils ( coreExprType )
import Id ( idType, mkSysLocal,
import MkId ( mkSysLocal )
import Id ( idType, mkIdWithNewType,
nullIdEnv, growIdEnvList, lookupIdEnv,
mkIdWithNewType,
IdEnv, GenId{-instances-}, Id
IdEnv, Id
)
import Name ( isLocallyDefined, getSrcLoc, getOccString )
import TyCon ( isBoxedTyCon, TyCon{-instance-} )
......@@ -123,13 +123,9 @@ liftCoreExpr expr@(Var var)
liftCoreExpr expr@(Lit lit) = returnL expr
liftCoreExpr (SCC label expr)
liftCoreExpr (Note note expr)
= liftCoreExpr expr `thenL` \ expr ->
returnL (SCC label expr)
liftCoreExpr (Coerce coerce ty expr)
= liftCoreExpr expr `thenL` \ expr ->
returnL (Coerce coerce ty expr) -- ToDo:right?:Coerce
returnL (Note note expr)
liftCoreExpr (Let (NonRec binder rhs) body) -- special case: no lifting
= liftCoreExpr rhs `thenL` \ rhs ->
......
ghc/compiler/coreSyn/CoreLint.lhs
View file @ 2c8f04b5
......@@ -30,7 +30,6 @@ import Name ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-},
NamedThing(..) )
import PprCore
import ErrUtils ( doIfSet, ghcExit )
import PprType ( GenType, GenTyVar, TyCon )
import PrimOp ( primOpType )
import PrimRep ( PrimRep(..) )
import SrcLoc ( SrcLoc )
......@@ -39,7 +38,7 @@ import Type ( mkFunTy, splitFunTy_maybe, mkForAllTy,
isUnpointedType, typeKind, instantiateTy,
splitAlgTyConApp_maybe, Type
)
import TyCon ( isPrimTyCon, isDataTyCon )
import TyCon ( TyCon, isPrimTyCon, isDataTyCon )
import TyVar ( TyVar, tyVarKind, mkTyVarEnv )
import ErrUtils ( ErrMsg )
import Unique ( Unique )
......@@ -205,10 +204,16 @@ lintCoreExpr (Var var)
| otherwise = checkInScope var `seqL` returnL (Just (idType var))
lintCoreExpr (Lit lit) = returnL (Just (literalType lit))
lintCoreExpr (SCC _ expr) = lintCoreExpr expr
lintCoreExpr e@(Coerce coercion ty expr)
= lintCoercion e coercion `seqL`
lintCoreExpr expr `seqL` returnL (Just ty)
lintCoreExpr (Note (Coerce to_ty from_ty) expr)
= lintCoreExpr expr `thenMaybeL` \ expr_ty ->
lintTy to_ty `seqL`
lintTy from_ty `seqL`
checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty) `seqL`
returnL (Just to_ty)
lintCoreExpr (Note other_note expr)
= lintCoreExpr expr
lintCoreExpr (Let binds body)
= lintCoreBinding binds `thenL` \binders ->
......@@ -297,7 +302,8 @@ lintCoreArg e ty (VarArg v)
var_ty = idType v
lintCoreArg e ty a@(TyArg arg_ty)
= -- ToDo: Check that ty is well-kinded and has no unbound tyvars
= lintTy arg_ty `seqL`
case (splitForAllTy_maybe ty) of
Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
......@@ -406,19 +412,17 @@ lintDeflt deflt@(