Commit 0596517a authored by partain's avatar partain
Browse files

[project @ 1996-03-21 12:46:33 by partain]

Final compiler stuff before Sansom renamer 960321
parent 6c381e87
......@@ -216,8 +216,7 @@ stranal/WwLib.lhs \
stranal/WorkWrap.lhs \
\
profiling/SCCauto.lhs \
profiling/SCCfinal.lhs \
profiling/CostCentre.lhs
profiling/SCCfinal.lhs
#if GhcWithDeforester != YES
#define __omit_deforester_flag -DOMIT_DEFORESTER=1
......@@ -924,7 +923,7 @@ compile(parser/U_ttype,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
/* *** misc *************************************************** */
DEPSRCS = $(ALLSRCS_LHS) $(ALLSRCS_HS)
DEPSRCS = $(ALLSRCS_LHS) $(ALLSRCS_HS) SIMPL_SRCS_LHS
#if GhcWithHscBuiltViaC == NO
MKDEPENDHS_OPTS= -I$(MAIN_INCLUDE_DIR) -I$(COMPINFO_DIR) -x HsVersions.h
......
......@@ -110,12 +110,14 @@ import PprStyle
import Pretty
import SrcLoc ( mkBuiltinSrcLoc )
import TyCon ( TyCon, mkTupleTyCon, getTyConDataCons )
import Type ( mkSigmaTy, mkTyVarTy, mkFunTys, mkDictTy,
applyTyCon, isPrimType, instantiateTy,
GenType, ThetaType(..), TauType(..), Type(..) )
import TyVar ( GenTyVar, alphaTyVars )
import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
applyTyCon, isPrimType, instantiateTy,
tyVarsOfType,
GenType, ThetaType(..), TauType(..), Type(..)
)
import TyVar ( GenTyVar, alphaTyVars, isEmptyTyVarSet )
import UniqFM
import UniqSet ( UniqSet(..) )
import UniqSet -- practically all of it
import Unique ( Unique, mkTupleDataConUnique, pprUnique, showUnique )
import Util ( mapAccumL, nOfThem, panic, pprPanic, assertPanic )
\end{code}
......@@ -480,7 +482,7 @@ toplevelishId (Id _ _ details _ _)
chk (PreludeId _) = True
chk (TopLevId _) = True -- NB: see notes
chk (SuperDictSelId _ _) = True
chk (MethodSelId _ _) = True
chk (MethodSelId _ _) = True
chk (DefaultMethodId _ _ _) = True
chk (DictFunId _ _ _ _) = True
chk (ConstMethodId _ _ _ _ _) = True
......@@ -501,7 +503,7 @@ idHasNoFreeTyVars (Id _ _ details _ info)
chk (PreludeId _) = True
chk (TopLevId _) = True
chk (SuperDictSelId _ _) = True
chk (MethodSelId _ _) = True
chk (MethodSelId _ _) = True
chk (DefaultMethodId _ _ _) = True
chk (DictFunId _ _ _ _) = True
chk (ConstMethodId _ _ _ _ _) = True
......@@ -814,10 +816,11 @@ externallyVisibleId id@(Id _ _ details _ _)
\end{code}
\begin{code}
{-LATER:
idWantsToBeINLINEd :: Id -> Bool
idWantsToBeINLINEd id
= panic "Id.idWantsToBeINLINEd"
{- LATER:
= case (getIdUnfolding id) of
IWantToBeINLINEd _ -> True
_ -> False
......@@ -1176,11 +1179,14 @@ updateIdType (Id u _ info details) ty = Id u ty info details
\end{code}
\begin{code}
no_free_tvs ty = panic "Id:no_free_tvs" -- null (extractTyVarsFromTy ty)
type MyTy a b = GenType (GenTyVar a) b
type MyId a b = GenId (MyTy a b)
no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
-- SysLocal: for an Id being created by the compiler out of thin air...
-- UserLocal: an Id with a name the user might recognize...
mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> ty -> SrcLoc -> GenId ty
mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
mkSysLocal str uniq ty loc
= Id uniq ty (SysLocalId (mkShortName str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
......@@ -1189,7 +1195,7 @@ mkUserLocal str uniq ty loc
= Id uniq ty (LocalId (mkShortName str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
-- mkUserId builds a local or top-level Id, depending on the name given
mkUserId :: Name -> ty -> PragmaInfo -> GenId ty
mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
mkUserId (Short uniq short) ty pragma_info
= Id uniq ty (LocalId short (no_free_tvs ty)) pragma_info noIdInfo
mkUserId (ValName uniq full) ty pragma_info
......@@ -1342,7 +1348,7 @@ mkDataCon k n stricts tvs ctxt args_tys tycon
type_of_constructor
= mkSigmaTy tvs ctxt
(mkFunTys args_tys (applyTyCon tycon (map mkTyVarTy tvs)))
(mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
datacon_info = noIdInfo `addInfo_UF` unfolding
`addInfo` mkArityInfo arity
......@@ -1358,7 +1364,7 @@ mkDataCon k n stricts tvs ctxt args_tys tycon
-- else -- do some business...
let
(tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
tyvar_tys = map mkTyVarTy tyvars
tyvar_tys = mkTyVarTys tyvars
in
BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
......@@ -1406,7 +1412,7 @@ mkTupleCon arity
(mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
tycon = mkTupleTyCon arity
tyvars = take arity alphaTyVars
tyvar_tys = map mkTyVarTy tyvars
tyvar_tys = mkTyVarTys tyvars
tuplecon_info
= noIdInfo `addInfo_UF` unfolding
......@@ -1421,7 +1427,7 @@ mkTupleCon arity
-- else -- do some business...
let
(tyvars, dict_vars, vars) = mk_uf_bits arity
tyvar_tys = map mkTyVarTy tyvars
tyvar_tys = mkTyVarTys tyvars
in
BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
......@@ -1463,7 +1469,7 @@ getDataConSig (Id _ _ (TupleConId arity) _ _)
= (tyvars, [], tyvar_tys, mkTupleTyCon arity)
where
tyvars = take arity alphaTyVars
tyvar_tys = map mkTyVarTy tyvars
tyvar_tys = mkTyVarTys tyvars
\end{code}
{- LATER
......@@ -1758,7 +1764,7 @@ is_prelude_core_ty :: Type -> Bool
is_prelude_core_ty inst_ty
= panic "Id.is_prelude_core_ty"
{- LATER
= case maybeDataTyCon inst_ty of
= case maybeAppDataTyCon inst_ty of
Just (tycon,_,_) -> fromPreludeCore tycon
Nothing -> panic "Id: is_prelude_core_ty"
-}
......@@ -2042,4 +2048,26 @@ modifyIdEnv env mangle_fn key
\begin{code}
type GenIdSet ty = UniqSet (GenId ty)
type IdSet = UniqSet (GenId Type)
emptyIdSet :: GenIdSet ty
intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
unionIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty
idSetToList :: GenIdSet ty -> [GenId ty]
singletonIdSet :: GenId ty -> GenIdSet ty
elementOfIdSet :: GenId ty -> GenIdSet ty -> Bool
minusIdSet :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
isEmptyIdSet :: GenIdSet ty -> Bool
mkIdSet :: [GenId ty] -> GenIdSet ty
emptyIdSet = emptyUniqSet
singletonIdSet = singletonUniqSet
intersectIdSets = intersectUniqSets
unionIdSets = unionUniqSets
unionManyIdSets = unionManyUniqSets
idSetToList = uniqSetToList
elementOfIdSet = elementOfUniqSet
minusIdSet = minusUniqSet
isEmptyIdSet = isEmptyUniqSet
mkIdSet = mkUniqSet
\end{code}
......@@ -14,7 +14,7 @@ module UniqSupply (
UniqSM(..), -- type: unique supply monad
initUs, thenUs, returnUs,
mapUs, mapAndUnzipUs,
mapUs, mapAndUnzipUs, mapAndUnzip3Us,
mkSplitUniqSupply,
splitUniqSupply,
......@@ -156,12 +156,19 @@ mapUs f (x:xs)
returnUs (r:rs)
mapAndUnzipUs :: (a -> UniqSM (b,c)) -> [a] -> UniqSM ([b],[c])
mapAndUnzip3Us :: (a -> UniqSM (b,c,d)) -> [a] -> UniqSM ([b],[c],[d])
mapAndUnzipUs f [] = returnUs ([],[])
mapAndUnzipUs f (x:xs)
= f x `thenUs` \ (r1, r2) ->
mapAndUnzipUs f xs `thenUs` \ (rs1, rs2) ->
returnUs (r1:rs1, r2:rs2)
mapAndUnzip3Us f [] = returnUs ([],[],[])
mapAndUnzip3Us f (x:xs)
= f x `thenUs` \ (r1, r2, r3) ->
mapAndUnzip3Us f xs `thenUs` \ (rs1, rs2, rs3) ->
returnUs (r1:rs1, r2:rs2, r3:rs3)
\end{code}
%************************************************************************
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[AnnCoreSyntax]{Annotated core syntax}
......@@ -16,106 +16,91 @@ module AnnCoreSyn (
AnnCoreCaseAlts(..), AnnCoreCaseDefault(..),
deAnnotate -- we may eventually export some of the other deAnners
-- and to make the interface self-sufficient
) where
import PrelInfo ( PrimOp(..), PrimRep
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
import Literal ( Literal )
import Ubiq{-uitous-}
import CoreSyn
import Outputable
import CostCentre ( CostCentre )
#if USE_ATTACK_PRAGMAS
import Util
#endif
\end{code}
\begin{code}
data AnnCoreBinding binder bindee annot
= AnnCoNonRec binder (AnnCoreExpr binder bindee annot)
| AnnCoRec [(binder, AnnCoreExpr binder bindee annot)]
data AnnCoreBinding val_bdr val_occ tyvar uvar annot
= AnnNonRec val_bdr (AnnCoreExpr val_bdr val_occ tyvar uvar annot)
| AnnRec [(val_bdr, AnnCoreExpr val_bdr val_occ tyvar uvar annot)]
\end{code}
\begin{code}
type AnnCoreExpr binder bindee annot = (annot, AnnCoreExpr' binder bindee annot)
data AnnCoreExpr' binder bindee annot
= AnnCoVar bindee
| AnnCoLit Literal
type AnnCoreExpr val_bdr val_occ tyvar uvar annot
= (annot, AnnCoreExpr' val_bdr val_occ tyvar uvar annot)
| AnnCoCon Id [Type] [GenCoreAtom bindee]
data AnnCoreExpr' val_bdr val_occ tyvar uvar annot
= AnnVar val_occ
| AnnLit Literal
| AnnCoPrim PrimOp [Type] [GenCoreAtom bindee]
| AnnCon Id [GenCoreArg val_occ tyvar uvar]
| AnnPrim PrimOp [GenCoreArg val_occ tyvar uvar]
| AnnCoLam binder
(AnnCoreExpr binder bindee annot)
| AnnCoTyLam TyVar
(AnnCoreExpr binder bindee annot)
| AnnLam (GenCoreBinder val_bdr tyvar uvar)
(AnnCoreExpr val_bdr val_occ tyvar uvar annot)
| AnnCoApp (AnnCoreExpr binder bindee annot)
(GenCoreAtom bindee)
| AnnCoTyApp (AnnCoreExpr binder bindee annot)
Type
| AnnApp (AnnCoreExpr val_bdr val_occ tyvar uvar annot)
(GenCoreArg val_occ tyvar uvar)
| AnnCoCase (AnnCoreExpr binder bindee annot)
(AnnCoreCaseAlts binder bindee annot)
| AnnCase (AnnCoreExpr val_bdr val_occ tyvar uvar annot)
(AnnCoreCaseAlts val_bdr val_occ tyvar uvar annot)
| AnnCoLet (AnnCoreBinding binder bindee annot)
(AnnCoreExpr binder bindee annot)
| AnnLet (AnnCoreBinding val_bdr val_occ tyvar uvar annot)
(AnnCoreExpr val_bdr val_occ tyvar uvar annot)
| AnnCoSCC CostCentre
(AnnCoreExpr binder bindee annot)
| AnnSCC CostCentre
(AnnCoreExpr val_bdr val_occ tyvar uvar annot)
\end{code}
\begin{code}
data AnnCoreCaseAlts binder bindee annot
= AnnCoAlgAlts [(Id,
[binder],
AnnCoreExpr binder bindee annot)]
(AnnCoreCaseDefault binder bindee annot)
| AnnCoPrimAlts [(Literal,
AnnCoreExpr binder bindee annot)]
(AnnCoreCaseDefault binder bindee annot)
data AnnCoreCaseDefault binder bindee annot
= AnnCoNoDefault
| AnnCoBindDefault binder
(AnnCoreExpr binder bindee annot)
data AnnCoreCaseAlts val_bdr val_occ tyvar uvar annot
= AnnAlgAlts [(Id,
[val_bdr],
AnnCoreExpr val_bdr val_occ tyvar uvar annot)]
(AnnCoreCaseDefault val_bdr val_occ tyvar uvar annot)
| AnnPrimAlts [(Literal,
AnnCoreExpr val_bdr val_occ tyvar uvar annot)]
(AnnCoreCaseDefault val_bdr val_occ tyvar uvar annot)
data AnnCoreCaseDefault val_bdr val_occ tyvar uvar annot
= AnnNoDefault
| AnnBindDefault val_bdr
(AnnCoreExpr val_bdr val_occ tyvar uvar annot)
\end{code}
\begin{code}
deAnnotate :: AnnCoreExpr bndr bdee ann -> GenCoreExpr bndr bdee
deAnnotate (_, AnnCoVar v) = Var v
deAnnotate (_, AnnCoLit lit) = Lit lit
deAnnotate (_, AnnCoCon con tys args) = Con con tys args
deAnnotate (_, AnnCoPrim op tys args) = Prim op tys args
deAnnotate (_, AnnCoLam binder body) = Lam binder (deAnnotate body)
deAnnotate (_, AnnCoTyLam tyvar body) = CoTyLam tyvar (deAnnotate body)
deAnnotate (_, AnnCoApp fun arg) = App (deAnnotate fun) arg
deAnnotate (_, AnnCoTyApp fun ty) = CoTyApp (deAnnotate fun) ty
deAnnotate (_, AnnCoSCC lbl body) = SCC lbl (deAnnotate body)
deAnnotate (_, AnnCoLet bind body)
deAnnotate :: AnnCoreExpr val_bdr val_occ tyvar uvar ann
-> GenCoreExpr val_bdr val_occ tyvar uvar
deAnnotate (_, AnnVar v) = Var v
deAnnotate (_, AnnLit lit) = Lit lit
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 (_, AnnLet bind body)
= Let (deAnnBind bind) (deAnnotate body)
where
deAnnBind (AnnCoNonRec var rhs) = NonRec var (deAnnotate rhs)
deAnnBind (AnnCoRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
deAnnotate (_, AnnCoCase scrut alts)
deAnnotate (_, AnnCase scrut alts)
= Case (deAnnotate scrut) (deAnnAlts alts)
where
deAnnAlts (AnnCoAlgAlts alts deflt)
deAnnAlts (AnnAlgAlts alts deflt)
= AlgAlts [(con,args,deAnnotate rhs) | (con,args,rhs) <- alts]
(deAnnDeflt deflt)
deAnnAlts (AnnCoPrimAlts alts deflt)
deAnnAlts (AnnPrimAlts alts deflt)
= PrimAlts [(lit,deAnnotate rhs) | (lit,rhs) <- alts]
(deAnnDeflt deflt)
deAnnDeflt AnnCoNoDefault = NoDefault
deAnnDeflt (AnnCoBindDefault var rhs) = BindDefault var (deAnnotate rhs)
deAnnDeflt AnnNoDefault = NoDefault
deAnnDeflt (AnnBindDefault var rhs) = BindDefault var (deAnnotate rhs)
\end{code}
......@@ -8,7 +8,7 @@
module CoreSyn (
GenCoreBinding(..), GenCoreExpr(..),
GenCoreArg(..),GenCoreBinder(..), GenCoreCaseAlts(..),
GenCoreArg(..), GenCoreBinder(..), GenCoreCaseAlts(..),
GenCoreCaseDefault(..),
bindersOf, pairsFromCoreBinds, rhssOfBind,
......@@ -17,9 +17,9 @@ module CoreSyn (
mkApp, mkCon, mkPrim,
mkValLam, mkTyLam, mkUseLam,
mkLam,
digForLambdas,
collectBinders,
collectArgs, isValArg,
collectArgs, isValArg, notValArg, numValArgs,
mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase,
mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase,
......@@ -143,10 +143,10 @@ desugarer sets up constructors as applications of global @Vars@s.
Ye olde abstraction and application operators.
\begin{code}
| Lam (GenCoreBinder val_bdr tyvar uvar)
(GenCoreExpr val_bdr val_occ tyvar uvar)
(GenCoreExpr val_bdr val_occ tyvar uvar)
| App (GenCoreExpr val_bdr val_occ tyvar uvar)
(GenCoreArg val_occ tyvar uvar)
(GenCoreArg val_occ tyvar uvar)
\end{code}
Case expressions (\tr{case <expr> of <List of alternatives>}): there
......@@ -369,23 +369,23 @@ mkLam tyvars valvars body
\end{code}
We often want to strip off leading lambdas before getting down to
business. @digForLambdas@ is your friend.
business. @collectBinders@ is your friend.
We expect (by convention) usage-, type-, and value- lambdas in that
order.
\begin{code}
digForLambdas ::
collectBinders ::
GenCoreExpr val_bdr val_occ tyvar uvar ->
([uvar], [tyvar], [val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar)
digForLambdas (Lam (UsageBinder u) body)
collectBinders (Lam (UsageBinder u) body)
= let
(uvars, tyvars, args, final_body) = digForLambdas body
(uvars, tyvars, args, final_body) = collectBinders body
in
(u:uvars, tyvars, args, final_body)
digForLambdas other
collectBinders other
= let
(tyvars, args, body) = dig_for_tyvars other
in
......@@ -468,6 +468,10 @@ is_Lit_or_Var a
isValArg (LitArg _) = True -- often used for sanity-checking
isValArg (VarArg _) = True
isValArg _ = False
notValArg = not . isValArg -- exists only because it's a common use of isValArg
numValArgs as = length [ a | a <- as, isValArg a ] -- again, convenience
\end{code}
\begin{code}
......
......@@ -248,7 +248,7 @@ calcUnfoldingGuidance
calcUnfoldingGuidance scc_s_OK bOMB_OUT_SIZE expr
= let
(use_binders, ty_binders, val_binders, body) = digForLambdas expr
(use_binders, ty_binders, val_binders, body) = collectBinders expr
in
case (sizeExpr scc_s_OK bOMB_OUT_SIZE val_binders body) of
......@@ -292,7 +292,7 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
= if scc_s_OK then size_up body else Nothing
size_up (Con con args) = -- 1 + # of val args
sizeN (1 + length [ va | va <- args, isValArg va ])
sizeN (1 + numValArgs args)
size_up (Prim op args) = sizeN op_cost -- NB: no charge for PrimOp args
where
op_cost = if primOpCanTriggerGC op
......@@ -303,7 +303,7 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
size_up expr@(Lam _ _)
= let
(uvars, tyvars, args, body) = digForLambdas expr
(uvars, tyvars, args, body) = collectBinders expr
in
size_up body `addSizeN` length args
......@@ -528,7 +528,7 @@ ment_expr (Lit l) = consider_lit l
ment_expr expr@(Lam _ _)
= let
(uvars, tyvars, args, body) = digForLambdas expr
(uvars, tyvars, args, body) = collectBinders expr
in
extractIdsUf args `thenUf` \ bs_ids ->
addInScopesUf bs_ids (
......
......@@ -15,8 +15,8 @@ module CoreUtils (
, mkErrorApp, escErrorMsg
, argToExpr
, unTagBinders, unTagBindersAlts
, manifestlyWHNF, manifestlyBottom
{- exprSmallEnoughToDup,
manifestlyWHNF, manifestlyBottom,
coreExprArity,
isWrapperFor,
maybeErrorApp,
......@@ -31,11 +31,12 @@ import IdLoop -- for pananoia-checking purposes
import CoreSyn
import CostCentre ( isDictCC )
import Id ( idType, mkSysLocal,
import Id ( idType, mkSysLocal, getIdArity, isBottomingId,
addOneToIdEnv, growIdEnvList, lookupIdEnv,
isNullIdEnv, IdEnv(..),
GenId{-instances-}
)
import IdInfo ( arityMaybe )
import Literal ( literalType, isNoRepLit, Literal(..) )
import Maybes ( catMaybes )
import PprCore ( GenCoreExpr{-instances-}, GenCoreArg{-instances-} )
......@@ -259,6 +260,7 @@ exprSmallEnoughToDup expr -- for now, just: <var> applied to <args>
&& length args <= 6 -- or 10 or 1 or 4 or anything smallish.
_ -> False
}
-}
\end{code}
Question (ADR): What is the above used for? Is a _ccall_ really small
enough?
......@@ -269,29 +271,31 @@ errs on the conservative side (returning \tr{False})---I've probably
left something out... [WDP]
\begin{code}
manifestlyWHNF :: GenCoreExpr bndr Id -> Bool
manifestlyWHNF :: GenCoreExpr bndr Id tyvar uvar -> Bool
manifestlyWHNF (Var _) = True
manifestlyWHNF (Lit _) = True
manifestlyWHNF (Con _ _) = True
manifestlyWHNF (SCC _ e) = manifestlyWHNF e
manifestlyWHNF (Let _ e) = False
manifestlyWHNF (Case _ _) = False
manifestlyWHNF (Var _) = True
manifestlyWHNF (Lit _) = True
manifestlyWHNF (Con _ _ _) = True -- ToDo: anything for Prim?
manifestlyWHNF (Lam _ _) = True
manifestlyWHNF (CoTyLam _ e) = manifestlyWHNF e
manifestlyWHNF (SCC _ e) = manifestlyWHNF e
manifestlyWHNF (Let _ e) = False
manifestlyWHNF (Case _ _) = False
manifestlyWHNF (Lam (ValBinder _) _) = True
manifestlyWHNF (Lam other_binder e) = manifestlyWHNF e
manifestlyWHNF other_expr -- look for manifest partial application
= case (collectArgs other_expr) of { (fun, args) ->
case fun of
Var f -> let
num_val_args = length [ a | (ValArg a) <- args ]
in
num_val_args == 0 || -- Just a type application of
-- a variable (f t1 t2 t3)
-- counts as WHNF
case (arityMaybe (getIdArity f)) of
Nothing -> False
Just arity -> num_val_args < arity
Var f -> let
num_val_args = numValArgs args
in
num_val_args == 0 -- Just a type application of
-- a variable (f t1 t2 t3);
-- counts as WHNF.
||
case (arityMaybe (getIdArity f)) of
Nothing -> False
Just arity -> num_val_args < arity
_ -> False
}
......@@ -303,17 +307,19 @@ some point. It isn't a disaster if it errs on the conservative side
(returning \tr{False}).
\begin{code}
manifestlyBottom :: GenCoreExpr bndr Id -> Bool
manifestlyBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
manifestlyBottom (Var v) = isBottomingId v
manifestlyBottom (Lit _) = False
manifestlyBottom (Con _ _ _) = False
manifestlyBottom (Prim _ _ _)= False
manifestlyBottom (Lam _ _) = False -- we do not assume \x.bottom == bottom. should we? ToDo
manifestlyBottom (CoTyLam _ e) = manifestlyBottom e
manifestlyBottom (Con _ _) = False
manifestlyBottom (Prim _ _) = False
manifestlyBottom (SCC _ e) = manifestlyBottom e
manifestlyBottom (Let _ e) = manifestlyBottom e
-- We do not assume \x.bottom == bottom:
manifestlyBottom (Lam (ValBinder _) _) = False
manifestlyBottom (Lam other_binder e) = manifestlyBottom e
manifestlyBottom (Case e a)
= manifestlyBottom e
|| (case a of
......@@ -331,15 +337,16 @@ manifestlyBottom (Case e a)
manifestlyBottom other_expr -- look for manifest partial application
= case (collectArgs other_expr) of { (fun, args) ->
case fun of
Var f | isBottomingId f -> True -- Application of a function which
-- always gives bottom; we treat this as
-- a WHNF, because it certainly doesn't
-- need to be shared!
Var f | isBottomingId f -> True
-- Application of a function which always gives
-- bottom; we treat this as a WHNF, because it
-- certainly doesn't need to be shared!
_ -> False
}
\end{code}
\begin{code}
{-LATER:
coreExprArity
:: (Id -> Maybe (GenCoreExpr bndr Id))
-> GenCoreExpr bndr Id
......@@ -371,7 +378,7 @@ Probably a little too HACKY [WDP].
isWrapperFor :: CoreExpr -> Id -> Bool
expr `isWrapperFor` var
= case (digForLambdas expr) of { (_, _, args, body) -> -- lambdas off the front
= case (collectBinders expr) of { (_, _, args, body) -> -- lambdas off the front
unravel_casing args body
--NO, THANKS: && not (null args)
}
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
Taken quite directly from the Peyton Jones/Lester paper.
......@@ -18,24 +18,28 @@ module FreeVars (
CoreExprWithFVs(..), -- For the above functions
AnnCoreExpr(..), -- Dito
FVInfo(..), LeakInfo(..)
-- and to make the interface self-sufficient...
) where
import Ubiq{-uitous-}
import AnnCoreSyn -- output
import PrelInfo ( PrimOp(..), PrimRep -- for CCallOp
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
import CoreSyn
import Id ( idType, getIdArity, isBottomingId,
emptyIdSet, singletonIdSet, mkIdSet,
elementOfIdSet, minusIdSet, unionManyIdSets,
IdSet(..)
)
import IdInfo ( arityMaybe )
import PrimOp ( PrimOp(..) )
import Type ( tyVarsOfType )
import TyVar ( emptyTyVarSet, singletonTyVarSet, minusTyVarSet,
intersectTyVarSets,
TyVarSet(..)